1 /* OpenMP directive matching and resolving.
2 Copyright (C) 2005, 2006, 2007, 2008
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"
32 /* Match an end of OpenMP directive. End of OpenMP directive is optional
33 whitespace, followed by '\n' or comment '!'. */
36 gfc_match_omp_eos (void)
41 old_loc
= gfc_current_locus
;
42 gfc_gobble_whitespace ();
44 c
= gfc_next_ascii_char ();
49 c
= gfc_next_ascii_char ();
57 gfc_current_locus
= old_loc
;
61 /* Free an omp_clauses structure. */
64 gfc_free_omp_clauses (gfc_omp_clauses
*c
)
70 gfc_free_expr (c
->if_expr
);
71 gfc_free_expr (c
->num_threads
);
72 gfc_free_expr (c
->chunk_size
);
73 for (i
= 0; i
< OMP_LIST_NUM
; i
++)
74 gfc_free_namelist (c
->lists
[i
]);
78 /* Match a variable/common block list and construct a namelist from it. */
81 gfc_match_omp_variable_list (const char *str
, gfc_namelist
**list
,
84 gfc_namelist
*head
, *tail
, *p
;
86 char n
[GFC_MAX_SYMBOL_LEN
+1];
93 old_loc
= gfc_current_locus
;
101 m
= gfc_match_symbol (&sym
, 1);
105 gfc_set_sym_referenced (sym
);
106 p
= gfc_get_namelist ();
125 m
= gfc_match (" / %n /", n
);
126 if (m
== MATCH_ERROR
)
131 st
= gfc_find_symtree (gfc_current_ns
->common_root
, n
);
134 gfc_error ("COMMON block /%s/ not found at %C", n
);
137 for (sym
= st
->n
.common
->head
; sym
; sym
= sym
->common_next
)
139 gfc_set_sym_referenced (sym
);
140 p
= gfc_get_namelist ();
152 if (gfc_match_char (')') == MATCH_YES
)
154 if (gfc_match_char (',') != MATCH_YES
)
159 list
= &(*list
)->next
;
165 gfc_error ("Syntax error in OpenMP variable list at %C");
168 gfc_free_namelist (head
);
169 gfc_current_locus
= old_loc
;
173 #define OMP_CLAUSE_PRIVATE (1 << 0)
174 #define OMP_CLAUSE_FIRSTPRIVATE (1 << 1)
175 #define OMP_CLAUSE_LASTPRIVATE (1 << 2)
176 #define OMP_CLAUSE_COPYPRIVATE (1 << 3)
177 #define OMP_CLAUSE_SHARED (1 << 4)
178 #define OMP_CLAUSE_COPYIN (1 << 5)
179 #define OMP_CLAUSE_REDUCTION (1 << 6)
180 #define OMP_CLAUSE_IF (1 << 7)
181 #define OMP_CLAUSE_NUM_THREADS (1 << 8)
182 #define OMP_CLAUSE_SCHEDULE (1 << 9)
183 #define OMP_CLAUSE_DEFAULT (1 << 10)
184 #define OMP_CLAUSE_ORDERED (1 << 11)
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 if (c
->default_sharing
!= OMP_DEFAULT_UNKNOWN
)
341 old_loc
= gfc_current_locus
;
342 if ((mask
& OMP_CLAUSE_SCHEDULE
)
343 && c
->sched_kind
== OMP_SCHED_NONE
344 && gfc_match ("schedule ( ") == MATCH_YES
)
346 if (gfc_match ("static") == MATCH_YES
)
347 c
->sched_kind
= OMP_SCHED_STATIC
;
348 else if (gfc_match ("dynamic") == MATCH_YES
)
349 c
->sched_kind
= OMP_SCHED_DYNAMIC
;
350 else if (gfc_match ("guided") == MATCH_YES
)
351 c
->sched_kind
= OMP_SCHED_GUIDED
;
352 else if (gfc_match ("runtime") == MATCH_YES
)
353 c
->sched_kind
= OMP_SCHED_RUNTIME
;
354 if (c
->sched_kind
!= OMP_SCHED_NONE
)
357 if (c
->sched_kind
!= OMP_SCHED_RUNTIME
)
358 m
= gfc_match (" , %e )", &c
->chunk_size
);
360 m
= gfc_match_char (')');
362 c
->sched_kind
= OMP_SCHED_NONE
;
364 if (c
->sched_kind
!= OMP_SCHED_NONE
)
367 gfc_current_locus
= old_loc
;
369 if ((mask
& OMP_CLAUSE_ORDERED
) && !c
->ordered
370 && gfc_match ("ordered") == MATCH_YES
)
372 c
->ordered
= needs_space
= true;
379 if (gfc_match_omp_eos () != MATCH_YES
)
381 gfc_free_omp_clauses (c
);
389 #define OMP_PARALLEL_CLAUSES \
390 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
391 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IF \
392 | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT)
393 #define OMP_DO_CLAUSES \
394 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
395 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
396 | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED)
397 #define OMP_SECTIONS_CLAUSES \
398 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
399 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
402 gfc_match_omp_parallel (void)
405 if (gfc_match_omp_clauses (&c
, OMP_PARALLEL_CLAUSES
) != MATCH_YES
)
407 new_st
.op
= EXEC_OMP_PARALLEL
;
408 new_st
.ext
.omp_clauses
= c
;
414 gfc_match_omp_critical (void)
416 char n
[GFC_MAX_SYMBOL_LEN
+1];
418 if (gfc_match (" ( %n )", n
) != MATCH_YES
)
420 if (gfc_match_omp_eos () != MATCH_YES
)
422 new_st
.op
= EXEC_OMP_CRITICAL
;
423 new_st
.ext
.omp_name
= n
[0] ? xstrdup (n
) : NULL
;
429 gfc_match_omp_do (void)
432 if (gfc_match_omp_clauses (&c
, OMP_DO_CLAUSES
) != MATCH_YES
)
434 new_st
.op
= EXEC_OMP_DO
;
435 new_st
.ext
.omp_clauses
= c
;
441 gfc_match_omp_flush (void)
443 gfc_namelist
*list
= NULL
;
444 gfc_match_omp_variable_list (" (", &list
, true);
445 if (gfc_match_omp_eos () != MATCH_YES
)
447 gfc_free_namelist (list
);
450 new_st
.op
= EXEC_OMP_FLUSH
;
451 new_st
.ext
.omp_namelist
= list
;
457 gfc_match_omp_threadprivate (void)
460 char n
[GFC_MAX_SYMBOL_LEN
+1];
465 old_loc
= gfc_current_locus
;
467 m
= gfc_match (" (");
473 m
= gfc_match_symbol (&sym
, 0);
477 if (sym
->attr
.in_common
)
478 gfc_error_now ("Threadprivate variable at %C is an element of "
480 else if (gfc_add_threadprivate (&sym
->attr
, sym
->name
,
481 &sym
->declared_at
) == FAILURE
)
490 m
= gfc_match (" / %n /", n
);
491 if (m
== MATCH_ERROR
)
493 if (m
== MATCH_NO
|| n
[0] == '\0')
496 st
= gfc_find_symtree (gfc_current_ns
->common_root
, n
);
499 gfc_error ("COMMON block /%s/ not found at %C", n
);
502 st
->n
.common
->threadprivate
= 1;
503 for (sym
= st
->n
.common
->head
; sym
; sym
= sym
->common_next
)
504 if (gfc_add_threadprivate (&sym
->attr
, sym
->name
,
505 &sym
->declared_at
) == FAILURE
)
509 if (gfc_match_char (')') == MATCH_YES
)
511 if (gfc_match_char (',') != MATCH_YES
)
518 gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
521 gfc_current_locus
= old_loc
;
527 gfc_match_omp_parallel_do (void)
530 if (gfc_match_omp_clauses (&c
, OMP_PARALLEL_CLAUSES
| OMP_DO_CLAUSES
)
533 new_st
.op
= EXEC_OMP_PARALLEL_DO
;
534 new_st
.ext
.omp_clauses
= c
;
540 gfc_match_omp_parallel_sections (void)
543 if (gfc_match_omp_clauses (&c
, OMP_PARALLEL_CLAUSES
| OMP_SECTIONS_CLAUSES
)
546 new_st
.op
= EXEC_OMP_PARALLEL_SECTIONS
;
547 new_st
.ext
.omp_clauses
= c
;
553 gfc_match_omp_parallel_workshare (void)
556 if (gfc_match_omp_clauses (&c
, OMP_PARALLEL_CLAUSES
) != MATCH_YES
)
558 new_st
.op
= EXEC_OMP_PARALLEL_WORKSHARE
;
559 new_st
.ext
.omp_clauses
= c
;
565 gfc_match_omp_sections (void)
568 if (gfc_match_omp_clauses (&c
, OMP_SECTIONS_CLAUSES
) != MATCH_YES
)
570 new_st
.op
= EXEC_OMP_SECTIONS
;
571 new_st
.ext
.omp_clauses
= c
;
577 gfc_match_omp_single (void)
580 if (gfc_match_omp_clauses (&c
, OMP_CLAUSE_PRIVATE
| OMP_CLAUSE_FIRSTPRIVATE
)
583 new_st
.op
= EXEC_OMP_SINGLE
;
584 new_st
.ext
.omp_clauses
= c
;
590 gfc_match_omp_workshare (void)
592 if (gfc_match_omp_eos () != MATCH_YES
)
594 new_st
.op
= EXEC_OMP_WORKSHARE
;
595 new_st
.ext
.omp_clauses
= gfc_get_omp_clauses ();
601 gfc_match_omp_master (void)
603 if (gfc_match_omp_eos () != MATCH_YES
)
605 new_st
.op
= EXEC_OMP_MASTER
;
606 new_st
.ext
.omp_clauses
= NULL
;
612 gfc_match_omp_ordered (void)
614 if (gfc_match_omp_eos () != MATCH_YES
)
616 new_st
.op
= EXEC_OMP_ORDERED
;
617 new_st
.ext
.omp_clauses
= NULL
;
623 gfc_match_omp_atomic (void)
625 if (gfc_match_omp_eos () != MATCH_YES
)
627 new_st
.op
= EXEC_OMP_ATOMIC
;
628 new_st
.ext
.omp_clauses
= NULL
;
634 gfc_match_omp_barrier (void)
636 if (gfc_match_omp_eos () != MATCH_YES
)
638 new_st
.op
= EXEC_OMP_BARRIER
;
639 new_st
.ext
.omp_clauses
= NULL
;
645 gfc_match_omp_end_nowait (void)
648 if (gfc_match ("% nowait") == MATCH_YES
)
650 if (gfc_match_omp_eos () != MATCH_YES
)
652 new_st
.op
= EXEC_OMP_END_NOWAIT
;
653 new_st
.ext
.omp_bool
= nowait
;
659 gfc_match_omp_end_single (void)
662 if (gfc_match ("% nowait") == MATCH_YES
)
664 new_st
.op
= EXEC_OMP_END_NOWAIT
;
665 new_st
.ext
.omp_bool
= true;
668 if (gfc_match_omp_clauses (&c
, OMP_CLAUSE_COPYPRIVATE
) != MATCH_YES
)
670 new_st
.op
= EXEC_OMP_END_SINGLE
;
671 new_st
.ext
.omp_clauses
= c
;
676 /* OpenMP directive resolving routines. */
679 resolve_omp_clauses (gfc_code
*code
)
681 gfc_omp_clauses
*omp_clauses
= code
->ext
.omp_clauses
;
684 static const char *clause_names
[]
685 = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
686 "COPYIN", "REDUCTION" };
688 if (omp_clauses
== NULL
)
691 if (omp_clauses
->if_expr
)
693 gfc_expr
*expr
= omp_clauses
->if_expr
;
694 if (gfc_resolve_expr (expr
) == FAILURE
695 || expr
->ts
.type
!= BT_LOGICAL
|| expr
->rank
!= 0)
696 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
699 if (omp_clauses
->num_threads
)
701 gfc_expr
*expr
= omp_clauses
->num_threads
;
702 if (gfc_resolve_expr (expr
) == FAILURE
703 || expr
->ts
.type
!= BT_INTEGER
|| expr
->rank
!= 0)
704 gfc_error ("NUM_THREADS clause at %L requires a scalar "
705 "INTEGER expression", &expr
->where
);
707 if (omp_clauses
->chunk_size
)
709 gfc_expr
*expr
= omp_clauses
->chunk_size
;
710 if (gfc_resolve_expr (expr
) == FAILURE
711 || expr
->ts
.type
!= BT_INTEGER
|| expr
->rank
!= 0)
712 gfc_error ("SCHEDULE clause's chunk_size at %L requires "
713 "a scalar INTEGER expression", &expr
->where
);
716 /* Check that no symbol appears on multiple clauses, except that
717 a symbol can appear on both firstprivate and lastprivate. */
718 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
719 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
722 if (n
->sym
->attr
.flavor
== FL_VARIABLE
)
724 if (n
->sym
->attr
.flavor
== FL_PROCEDURE
725 && n
->sym
->result
== n
->sym
726 && n
->sym
->attr
.function
)
728 if (gfc_current_ns
->proc_name
== n
->sym
729 || (gfc_current_ns
->parent
730 && gfc_current_ns
->parent
->proc_name
== n
->sym
))
732 if (gfc_current_ns
->proc_name
->attr
.entry_master
)
734 gfc_entry_list
*el
= gfc_current_ns
->entries
;
735 for (; el
; el
= el
->next
)
736 if (el
->sym
== n
->sym
)
741 if (gfc_current_ns
->parent
742 && gfc_current_ns
->parent
->proc_name
->attr
.entry_master
)
744 gfc_entry_list
*el
= gfc_current_ns
->parent
->entries
;
745 for (; el
; el
= el
->next
)
746 if (el
->sym
== n
->sym
)
752 gfc_error ("Object '%s' is not a variable at %L", n
->sym
->name
,
756 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
757 if (list
!= OMP_LIST_FIRSTPRIVATE
&& list
!= OMP_LIST_LASTPRIVATE
)
758 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
760 gfc_error ("Symbol '%s' present on multiple clauses at %L",
761 n
->sym
->name
, &code
->loc
);
765 gcc_assert (OMP_LIST_LASTPRIVATE
== OMP_LIST_FIRSTPRIVATE
+ 1);
766 for (list
= OMP_LIST_FIRSTPRIVATE
; list
<= OMP_LIST_LASTPRIVATE
; list
++)
767 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
770 gfc_error ("Symbol '%s' present on multiple clauses at %L",
771 n
->sym
->name
, &code
->loc
);
775 for (n
= omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
]; n
; n
= n
->next
)
777 gfc_error ("Symbol '%s' present on multiple clauses at %L",
778 n
->sym
->name
, &code
->loc
);
782 for (n
= omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
]; n
; n
= n
->next
)
785 for (n
= omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
]; n
; n
= n
->next
)
787 gfc_error ("Symbol '%s' present on multiple clauses at %L",
788 n
->sym
->name
, &code
->loc
);
792 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
793 if ((n
= omp_clauses
->lists
[list
]) != NULL
)
797 if (list
< OMP_LIST_REDUCTION_FIRST
)
798 name
= clause_names
[list
];
799 else if (list
<= OMP_LIST_REDUCTION_LAST
)
800 name
= clause_names
[OMP_LIST_REDUCTION_FIRST
];
806 case OMP_LIST_COPYIN
:
807 for (; n
!= NULL
; n
= n
->next
)
809 if (!n
->sym
->attr
.threadprivate
)
810 gfc_error ("Non-THREADPRIVATE object '%s' in COPYIN clause"
811 " at %L", n
->sym
->name
, &code
->loc
);
812 if (n
->sym
->attr
.allocatable
)
813 gfc_error ("COPYIN clause object '%s' is ALLOCATABLE at %L",
814 n
->sym
->name
, &code
->loc
);
815 if (n
->sym
->ts
.type
== BT_DERIVED
&& n
->sym
->ts
.derived
->attr
.alloc_comp
)
816 gfc_error ("COPYIN clause object '%s' at %L has ALLOCATABLE components",
817 n
->sym
->name
, &code
->loc
);
820 case OMP_LIST_COPYPRIVATE
:
821 for (; n
!= NULL
; n
= n
->next
)
823 if (n
->sym
->as
&& n
->sym
->as
->type
== AS_ASSUMED_SIZE
)
824 gfc_error ("Assumed size array '%s' in COPYPRIVATE clause "
825 "at %L", n
->sym
->name
, &code
->loc
);
826 if (n
->sym
->attr
.allocatable
)
827 gfc_error ("COPYPRIVATE clause object '%s' is ALLOCATABLE "
828 "at %L", n
->sym
->name
, &code
->loc
);
829 if (n
->sym
->ts
.type
== BT_DERIVED
&& n
->sym
->ts
.derived
->attr
.alloc_comp
)
830 gfc_error ("COPYPRIVATE clause object '%s' at %L has ALLOCATABLE components",
831 n
->sym
->name
, &code
->loc
);
834 case OMP_LIST_SHARED
:
835 for (; n
!= NULL
; n
= n
->next
)
837 if (n
->sym
->attr
.threadprivate
)
838 gfc_error ("THREADPRIVATE object '%s' in SHARED clause at "
839 "%L", n
->sym
->name
, &code
->loc
);
840 if (n
->sym
->attr
.cray_pointee
)
841 gfc_error ("Cray pointee '%s' in SHARED clause at %L",
842 n
->sym
->name
, &code
->loc
);
846 for (; n
!= NULL
; n
= n
->next
)
848 if (n
->sym
->attr
.threadprivate
)
849 gfc_error ("THREADPRIVATE object '%s' in %s clause at %L",
850 n
->sym
->name
, name
, &code
->loc
);
851 if (n
->sym
->attr
.cray_pointee
)
852 gfc_error ("Cray pointee '%s' in %s clause at %L",
853 n
->sym
->name
, name
, &code
->loc
);
854 if (list
!= OMP_LIST_PRIVATE
)
856 if (n
->sym
->attr
.pointer
)
857 gfc_error ("POINTER object '%s' in %s clause at %L",
858 n
->sym
->name
, name
, &code
->loc
);
859 if (n
->sym
->attr
.allocatable
)
860 gfc_error ("%s clause object '%s' is ALLOCATABLE at %L",
861 name
, n
->sym
->name
, &code
->loc
);
862 /* Variables in REDUCTION-clauses must be of intrinsic type (flagged below). */
863 if ((list
< OMP_LIST_REDUCTION_FIRST
|| list
> OMP_LIST_REDUCTION_LAST
) &&
864 n
->sym
->ts
.type
== BT_DERIVED
&& n
->sym
->ts
.derived
->attr
.alloc_comp
)
865 gfc_error ("%s clause object '%s' has ALLOCATABLE components at %L",
866 name
, n
->sym
->name
, &code
->loc
);
867 if (n
->sym
->attr
.cray_pointer
)
868 gfc_error ("Cray pointer '%s' in %s clause at %L",
869 n
->sym
->name
, name
, &code
->loc
);
871 if (n
->sym
->as
&& n
->sym
->as
->type
== AS_ASSUMED_SIZE
)
872 gfc_error ("Assumed size array '%s' in %s clause at %L",
873 n
->sym
->name
, name
, &code
->loc
);
874 if (n
->sym
->attr
.in_namelist
875 && (list
< OMP_LIST_REDUCTION_FIRST
876 || list
> OMP_LIST_REDUCTION_LAST
))
877 gfc_error ("Variable '%s' in %s clause is used in "
878 "NAMELIST statement at %L",
879 n
->sym
->name
, name
, &code
->loc
);
885 if (!gfc_numeric_ts (&n
->sym
->ts
))
886 gfc_error ("%c REDUCTION variable '%s' at %L must be of numeric type, got %s",
887 list
== OMP_LIST_PLUS
? '+'
888 : list
== OMP_LIST_MULT
? '*' : '-',
889 n
->sym
->name
, &code
->loc
,
890 gfc_typename (&n
->sym
->ts
));
896 if (n
->sym
->ts
.type
!= BT_LOGICAL
)
897 gfc_error ("%s REDUCTION variable '%s' must be LOGICAL "
899 list
== OMP_LIST_AND
? ".AND."
900 : list
== OMP_LIST_OR
? ".OR."
901 : list
== OMP_LIST_EQV
? ".EQV." : ".NEQV.",
902 n
->sym
->name
, &code
->loc
);
906 if (n
->sym
->ts
.type
!= BT_INTEGER
907 && n
->sym
->ts
.type
!= BT_REAL
)
908 gfc_error ("%s REDUCTION variable '%s' must be "
909 "INTEGER or REAL at %L",
910 list
== OMP_LIST_MAX
? "MAX" : "MIN",
911 n
->sym
->name
, &code
->loc
);
916 if (n
->sym
->ts
.type
!= BT_INTEGER
)
917 gfc_error ("%s REDUCTION variable '%s' must be INTEGER "
919 list
== OMP_LIST_IAND
? "IAND"
920 : list
== OMP_LIST_MULT
? "IOR" : "IEOR",
921 n
->sym
->name
, &code
->loc
);
923 /* Workaround for PR middle-end/26316, nothing really needs
924 to be done here for OMP_LIST_PRIVATE. */
925 case OMP_LIST_PRIVATE
:
926 gcc_assert (code
->op
!= EXEC_NOP
);
937 /* Return true if SYM is ever referenced in EXPR except in the SE node. */
940 expr_references_sym (gfc_expr
*e
, gfc_symbol
*s
, gfc_expr
*se
)
942 gfc_actual_arglist
*arg
;
943 if (e
== NULL
|| e
== se
)
945 switch (e
->expr_type
)
952 if (e
->symtree
!= NULL
953 && e
->symtree
->n
.sym
== s
)
958 && (expr_references_sym (e
->ref
->u
.ss
.start
, s
, se
)
959 || expr_references_sym (e
->ref
->u
.ss
.end
, s
, se
)))
963 if (expr_references_sym (e
->value
.op
.op2
, s
, se
))
965 return expr_references_sym (e
->value
.op
.op1
, s
, se
);
967 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
968 if (expr_references_sym (arg
->expr
, s
, se
))
977 /* If EXPR is a conversion function that widens the type
978 if WIDENING is true or narrows the type if WIDENING is false,
979 return the inner expression, otherwise return NULL. */
982 is_conversion (gfc_expr
*expr
, bool widening
)
984 gfc_typespec
*ts1
, *ts2
;
986 if (expr
->expr_type
!= EXPR_FUNCTION
987 || expr
->value
.function
.isym
== NULL
988 || expr
->value
.function
.esym
!= NULL
989 || expr
->value
.function
.isym
->id
!= GFC_ISYM_CONVERSION
)
995 ts2
= &expr
->value
.function
.actual
->expr
->ts
;
999 ts1
= &expr
->value
.function
.actual
->expr
->ts
;
1003 if (ts1
->type
> ts2
->type
1004 || (ts1
->type
== ts2
->type
&& ts1
->kind
> ts2
->kind
))
1005 return expr
->value
.function
.actual
->expr
;
1012 resolve_omp_atomic (gfc_code
*code
)
1017 code
= code
->block
->next
;
1018 gcc_assert (code
->op
== EXEC_ASSIGN
);
1019 gcc_assert (code
->next
== NULL
);
1021 if (code
->expr
->expr_type
!= EXPR_VARIABLE
1022 || code
->expr
->symtree
== NULL
1023 || code
->expr
->rank
!= 0
1024 || (code
->expr
->ts
.type
!= BT_INTEGER
1025 && code
->expr
->ts
.type
!= BT_REAL
1026 && code
->expr
->ts
.type
!= BT_COMPLEX
1027 && code
->expr
->ts
.type
!= BT_LOGICAL
))
1029 gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
1030 "intrinsic type at %L", &code
->loc
);
1034 var
= code
->expr
->symtree
->n
.sym
;
1035 expr2
= is_conversion (code
->expr2
, false);
1037 expr2
= code
->expr2
;
1039 if (expr2
->expr_type
== EXPR_OP
)
1041 gfc_expr
*v
= NULL
, *e
, *c
;
1042 gfc_intrinsic_op op
= expr2
->value
.op
.operator;
1043 gfc_intrinsic_op alt_op
= INTRINSIC_NONE
;
1047 case INTRINSIC_PLUS
:
1048 alt_op
= INTRINSIC_MINUS
;
1050 case INTRINSIC_TIMES
:
1051 alt_op
= INTRINSIC_DIVIDE
;
1053 case INTRINSIC_MINUS
:
1054 alt_op
= INTRINSIC_PLUS
;
1056 case INTRINSIC_DIVIDE
:
1057 alt_op
= INTRINSIC_TIMES
;
1063 alt_op
= INTRINSIC_NEQV
;
1065 case INTRINSIC_NEQV
:
1066 alt_op
= INTRINSIC_EQV
;
1069 gfc_error ("!$OMP ATOMIC assignment operator must be "
1070 "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
1075 /* Check for var = var op expr resp. var = expr op var where
1076 expr doesn't reference var and var op expr is mathematically
1077 equivalent to var op (expr) resp. expr op var equivalent to
1078 (expr) op var. We rely here on the fact that the matcher
1079 for x op1 y op2 z where op1 and op2 have equal precedence
1080 returns (x op1 y) op2 z. */
1081 e
= expr2
->value
.op
.op2
;
1082 if (e
->expr_type
== EXPR_VARIABLE
1083 && e
->symtree
!= NULL
1084 && e
->symtree
->n
.sym
== var
)
1086 else if ((c
= is_conversion (e
, true)) != NULL
1087 && c
->expr_type
== EXPR_VARIABLE
1088 && c
->symtree
!= NULL
1089 && c
->symtree
->n
.sym
== var
)
1093 gfc_expr
**p
= NULL
, **q
;
1094 for (q
= &expr2
->value
.op
.op1
; (e
= *q
) != NULL
; )
1095 if (e
->expr_type
== EXPR_VARIABLE
1096 && e
->symtree
!= NULL
1097 && e
->symtree
->n
.sym
== var
)
1102 else if ((c
= is_conversion (e
, true)) != NULL
)
1103 q
= &e
->value
.function
.actual
->expr
;
1104 else if (e
->expr_type
!= EXPR_OP
1105 || (e
->value
.op
.operator != op
1106 && e
->value
.op
.operator != alt_op
)
1112 q
= &e
->value
.op
.op1
;
1117 gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
1118 "or var = expr op var at %L", &expr2
->where
);
1125 switch (e
->value
.op
.operator)
1127 case INTRINSIC_MINUS
:
1128 case INTRINSIC_DIVIDE
:
1130 case INTRINSIC_NEQV
:
1131 gfc_error ("!$OMP ATOMIC var = var op expr not "
1132 "mathematically equivalent to var = var op "
1133 "(expr) at %L", &expr2
->where
);
1139 /* Canonicalize into var = var op (expr). */
1140 *p
= e
->value
.op
.op2
;
1141 e
->value
.op
.op2
= expr2
;
1143 if (code
->expr2
== expr2
)
1144 code
->expr2
= expr2
= e
;
1146 code
->expr2
->value
.function
.actual
->expr
= expr2
= e
;
1148 if (!gfc_compare_types (&expr2
->value
.op
.op1
->ts
, &expr2
->ts
))
1150 for (p
= &expr2
->value
.op
.op1
; *p
!= v
;
1151 p
= &(*p
)->value
.function
.actual
->expr
)
1154 gfc_free_expr (expr2
->value
.op
.op1
);
1155 expr2
->value
.op
.op1
= v
;
1156 gfc_convert_type (v
, &expr2
->ts
, 2);
1161 if (e
->rank
!= 0 || expr_references_sym (code
->expr2
, var
, v
))
1163 gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
1164 "must be scalar and cannot reference var at %L",
1169 else if (expr2
->expr_type
== EXPR_FUNCTION
1170 && expr2
->value
.function
.isym
!= NULL
1171 && expr2
->value
.function
.esym
== NULL
1172 && expr2
->value
.function
.actual
!= NULL
1173 && expr2
->value
.function
.actual
->next
!= NULL
)
1175 gfc_actual_arglist
*arg
, *var_arg
;
1177 switch (expr2
->value
.function
.isym
->id
)
1185 if (expr2
->value
.function
.actual
->next
->next
!= NULL
)
1187 gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
1188 "or IEOR must have two arguments at %L",
1194 gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
1195 "MIN, MAX, IAND, IOR or IEOR at %L",
1201 for (arg
= expr2
->value
.function
.actual
; arg
; arg
= arg
->next
)
1203 if ((arg
== expr2
->value
.function
.actual
1204 || (var_arg
== NULL
&& arg
->next
== NULL
))
1205 && arg
->expr
->expr_type
== EXPR_VARIABLE
1206 && arg
->expr
->symtree
!= NULL
1207 && arg
->expr
->symtree
->n
.sym
== var
)
1209 else if (expr_references_sym (arg
->expr
, var
, NULL
))
1210 gfc_error ("!$OMP ATOMIC intrinsic arguments except one must not "
1211 "reference '%s' at %L", var
->name
, &arg
->expr
->where
);
1212 if (arg
->expr
->rank
!= 0)
1213 gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
1214 "at %L", &arg
->expr
->where
);
1217 if (var_arg
== NULL
)
1219 gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
1220 "be '%s' at %L", var
->name
, &expr2
->where
);
1224 if (var_arg
!= expr2
->value
.function
.actual
)
1226 /* Canonicalize, so that var comes first. */
1227 gcc_assert (var_arg
->next
== NULL
);
1228 for (arg
= expr2
->value
.function
.actual
;
1229 arg
->next
!= var_arg
; arg
= arg
->next
)
1231 var_arg
->next
= expr2
->value
.function
.actual
;
1232 expr2
->value
.function
.actual
= var_arg
;
1237 gfc_error ("!$OMP ATOMIC assignment must have an operator or intrinsic "
1238 "on right hand side at %L", &expr2
->where
);
1245 struct pointer_set_t
*sharing_clauses
;
1246 struct pointer_set_t
*private_iterators
;
1247 struct omp_context
*previous
;
1249 gfc_code
*omp_current_do_code
;
1253 gfc_resolve_omp_do_blocks (gfc_code
*code
, gfc_namespace
*ns
)
1255 if (code
->block
->next
&& code
->block
->next
->op
== EXEC_DO
)
1256 omp_current_do_code
= code
->block
->next
;
1257 gfc_resolve_blocks (code
->block
, ns
);
1262 gfc_resolve_omp_parallel_blocks (gfc_code
*code
, gfc_namespace
*ns
)
1264 struct omp_context ctx
;
1265 gfc_omp_clauses
*omp_clauses
= code
->ext
.omp_clauses
;
1270 ctx
.sharing_clauses
= pointer_set_create ();
1271 ctx
.private_iterators
= pointer_set_create ();
1272 ctx
.previous
= omp_current_ctx
;
1273 omp_current_ctx
= &ctx
;
1275 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
1276 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
1277 pointer_set_insert (ctx
.sharing_clauses
, n
->sym
);
1279 if (code
->op
== EXEC_OMP_PARALLEL_DO
)
1280 gfc_resolve_omp_do_blocks (code
, ns
);
1282 gfc_resolve_blocks (code
->block
, ns
);
1284 omp_current_ctx
= ctx
.previous
;
1285 pointer_set_destroy (ctx
.sharing_clauses
);
1286 pointer_set_destroy (ctx
.private_iterators
);
1290 /* Note a DO iterator variable. This is special in !$omp parallel
1291 construct, where they are predetermined private. */
1294 gfc_resolve_do_iterator (gfc_code
*code
, gfc_symbol
*sym
)
1296 struct omp_context
*ctx
;
1298 if (sym
->attr
.threadprivate
)
1301 /* !$omp do and !$omp parallel do iteration variable is predetermined
1302 private just in the !$omp do resp. !$omp parallel do construct,
1303 with no implications for the outer parallel constructs. */
1304 if (code
== omp_current_do_code
)
1307 for (ctx
= omp_current_ctx
; ctx
; ctx
= ctx
->previous
)
1309 if (pointer_set_contains (ctx
->sharing_clauses
, sym
))
1312 if (! pointer_set_insert (ctx
->private_iterators
, sym
))
1314 gfc_omp_clauses
*omp_clauses
= ctx
->code
->ext
.omp_clauses
;
1317 p
= gfc_get_namelist ();
1319 p
->next
= omp_clauses
->lists
[OMP_LIST_PRIVATE
];
1320 omp_clauses
->lists
[OMP_LIST_PRIVATE
] = p
;
1327 resolve_omp_do (gfc_code
*code
)
1334 if (code
->ext
.omp_clauses
)
1335 resolve_omp_clauses (code
);
1337 do_code
= code
->block
->next
;
1338 if (do_code
->op
== EXEC_DO_WHILE
)
1339 gfc_error ("!$OMP DO cannot be a DO WHILE or DO without loop control "
1340 "at %L", &do_code
->loc
);
1343 gcc_assert (do_code
->op
== EXEC_DO
);
1344 if (do_code
->ext
.iterator
->var
->ts
.type
!= BT_INTEGER
)
1345 gfc_error ("!$OMP DO iteration variable must be of type integer at %L",
1347 dovar
= do_code
->ext
.iterator
->var
->symtree
->n
.sym
;
1348 if (dovar
->attr
.threadprivate
)
1349 gfc_error ("!$OMP DO iteration variable must not be THREADPRIVATE "
1350 "at %L", &do_code
->loc
);
1351 if (code
->ext
.omp_clauses
)
1352 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
1353 if (list
!= OMP_LIST_PRIVATE
&& list
!= OMP_LIST_LASTPRIVATE
)
1354 for (n
= code
->ext
.omp_clauses
->lists
[list
]; n
; n
= n
->next
)
1355 if (dovar
== n
->sym
)
1357 gfc_error ("!$OMP DO iteration variable present on clause "
1358 "other than PRIVATE or LASTPRIVATE at %L",
1366 /* Resolve OpenMP directive clauses and check various requirements
1367 of each directive. */
1370 gfc_resolve_omp_directive (gfc_code
*code
, gfc_namespace
*ns ATTRIBUTE_UNUSED
)
1375 case EXEC_OMP_PARALLEL_DO
:
1376 resolve_omp_do (code
);
1378 case EXEC_OMP_WORKSHARE
:
1379 case EXEC_OMP_PARALLEL_WORKSHARE
:
1380 case EXEC_OMP_PARALLEL
:
1381 case EXEC_OMP_PARALLEL_SECTIONS
:
1382 case EXEC_OMP_SECTIONS
:
1383 case EXEC_OMP_SINGLE
:
1384 if (code
->ext
.omp_clauses
)
1385 resolve_omp_clauses (code
);
1387 case EXEC_OMP_ATOMIC
:
1388 resolve_omp_atomic (code
);