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"
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)
185 #define OMP_CLAUSE_COLLAPSE (1 << 12)
186 #define OMP_CLAUSE_UNTIED (1 << 13)
188 /* Match OpenMP directive clauses. MASK is a bitmask of
189 clauses that are allowed for a particular directive. */
192 gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask)
194 gfc_omp_clauses *c = gfc_get_omp_clauses ();
196 bool needs_space = true, first = true;
201 if ((first || gfc_match_char (',') != MATCH_YES)
202 && (needs_space && gfc_match_space () != MATCH_YES))
206 gfc_gobble_whitespace ();
207 if ((mask & OMP_CLAUSE_IF) && c->if_expr == NULL
208 && gfc_match ("if ( %e )", &c->if_expr) == MATCH_YES)
210 if ((mask & OMP_CLAUSE_NUM_THREADS) && c->num_threads == NULL
211 && gfc_match ("num_threads ( %e )", &c->num_threads) == MATCH_YES)
213 if ((mask & OMP_CLAUSE_PRIVATE)
214 && gfc_match_omp_variable_list ("private (",
215 &c->lists[OMP_LIST_PRIVATE], true)
218 if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
219 && gfc_match_omp_variable_list ("firstprivate (",
220 &c->lists[OMP_LIST_FIRSTPRIVATE],
224 if ((mask & OMP_CLAUSE_LASTPRIVATE)
225 && gfc_match_omp_variable_list ("lastprivate (",
226 &c->lists[OMP_LIST_LASTPRIVATE],
230 if ((mask & OMP_CLAUSE_COPYPRIVATE)
231 && gfc_match_omp_variable_list ("copyprivate (",
232 &c->lists[OMP_LIST_COPYPRIVATE],
236 if ((mask & OMP_CLAUSE_SHARED)
237 && gfc_match_omp_variable_list ("shared (",
238 &c->lists[OMP_LIST_SHARED], true)
241 if ((mask & OMP_CLAUSE_COPYIN)
242 && gfc_match_omp_variable_list ("copyin (",
243 &c->lists[OMP_LIST_COPYIN], true)
246 old_loc = gfc_current_locus;
247 if ((mask & OMP_CLAUSE_REDUCTION)
248 && gfc_match ("reduction ( ") == MATCH_YES)
250 int reduction = OMP_LIST_NUM;
251 char buffer[GFC_MAX_SYMBOL_LEN + 1];
252 if (gfc_match_char ('+') == MATCH_YES)
253 reduction = OMP_LIST_PLUS;
254 else if (gfc_match_char ('*') == MATCH_YES)
255 reduction = OMP_LIST_MULT;
256 else if (gfc_match_char ('-') == MATCH_YES)
257 reduction = OMP_LIST_SUB;
258 else if (gfc_match (".and.") == MATCH_YES)
259 reduction = OMP_LIST_AND;
260 else if (gfc_match (".or.") == MATCH_YES)
261 reduction = OMP_LIST_OR;
262 else if (gfc_match (".eqv.") == MATCH_YES)
263 reduction = OMP_LIST_EQV;
264 else if (gfc_match (".neqv.") == MATCH_YES)
265 reduction = OMP_LIST_NEQV;
266 else if (gfc_match_name (buffer) == MATCH_YES)
269 const char *n = buffer;
271 gfc_find_symbol (buffer, NULL, 1, &sym);
274 if (sym->attr.intrinsic)
276 else if ((sym->attr.flavor != FL_UNKNOWN
277 && sym->attr.flavor != FL_PROCEDURE)
278 || sym->attr.external
283 || sym->attr.subroutine
286 || sym->attr.cray_pointer
287 || sym->attr.cray_pointee
288 || (sym->attr.proc != PROC_UNKNOWN
289 && sym->attr.proc != PROC_INTRINSIC)
290 || sym->attr.if_source != IFSRC_UNKNOWN
291 || sym == sym->ns->proc_name)
293 gfc_error_now ("%s is not INTRINSIC procedure name "
300 if (strcmp (n, "max") == 0)
301 reduction = OMP_LIST_MAX;
302 else if (strcmp (n, "min") == 0)
303 reduction = OMP_LIST_MIN;
304 else if (strcmp (n, "iand") == 0)
305 reduction = OMP_LIST_IAND;
306 else if (strcmp (n, "ior") == 0)
307 reduction = OMP_LIST_IOR;
308 else if (strcmp (n, "ieor") == 0)
309 reduction = OMP_LIST_IEOR;
310 if (reduction != OMP_LIST_NUM
312 && ! sym->attr.intrinsic
313 && ! sym->attr.use_assoc
314 && ((sym->attr.flavor == FL_UNKNOWN
315 && gfc_add_flavor (&sym->attr, FL_PROCEDURE,
316 sym->name, NULL) == FAILURE)
317 || gfc_add_intrinsic (&sym->attr, NULL) == FAILURE))
319 gfc_free_omp_clauses (c);
323 if (reduction != OMP_LIST_NUM
324 && gfc_match_omp_variable_list (" :", &c->lists[reduction],
329 gfc_current_locus = old_loc;
331 if ((mask & OMP_CLAUSE_DEFAULT)
332 && c->default_sharing == OMP_DEFAULT_UNKNOWN)
334 if (gfc_match ("default ( shared )") == MATCH_YES)
335 c->default_sharing = OMP_DEFAULT_SHARED;
336 else if (gfc_match ("default ( private )") == MATCH_YES)
337 c->default_sharing = OMP_DEFAULT_PRIVATE;
338 else if (gfc_match ("default ( none )") == MATCH_YES)
339 c->default_sharing = OMP_DEFAULT_NONE;
340 else if (gfc_match ("default ( firstprivate )") == MATCH_YES)
341 c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
342 if (c->default_sharing != OMP_DEFAULT_UNKNOWN)
345 old_loc = gfc_current_locus;
346 if ((mask & OMP_CLAUSE_SCHEDULE)
347 && c->sched_kind == OMP_SCHED_NONE
348 && gfc_match ("schedule ( ") == MATCH_YES)
350 if (gfc_match ("static") == MATCH_YES)
351 c->sched_kind = OMP_SCHED_STATIC;
352 else if (gfc_match ("dynamic") == MATCH_YES)
353 c->sched_kind = OMP_SCHED_DYNAMIC;
354 else if (gfc_match ("guided") == MATCH_YES)
355 c->sched_kind = OMP_SCHED_GUIDED;
356 else if (gfc_match ("runtime") == MATCH_YES)
357 c->sched_kind = OMP_SCHED_RUNTIME;
358 else if (gfc_match ("auto") == MATCH_YES)
359 c->sched_kind = OMP_SCHED_AUTO;
360 if (c->sched_kind != OMP_SCHED_NONE)
363 if (c->sched_kind != OMP_SCHED_RUNTIME
364 && c->sched_kind != OMP_SCHED_AUTO)
365 m = gfc_match (" , %e )", &c->chunk_size);
367 m = gfc_match_char (')');
369 c->sched_kind = OMP_SCHED_NONE;
371 if (c->sched_kind != OMP_SCHED_NONE)
374 gfc_current_locus = old_loc;
376 if ((mask & OMP_CLAUSE_ORDERED) && !c->ordered
377 && gfc_match ("ordered") == MATCH_YES)
379 c->ordered = needs_space = true;
382 if ((mask & OMP_CLAUSE_UNTIED) && !c->untied
383 && gfc_match ("untied") == MATCH_YES)
385 c->untied = needs_space = true;
388 if ((mask & OMP_CLAUSE_COLLAPSE) && !c->collapse)
390 gfc_expr *cexpr = NULL;
391 match m = gfc_match ("collapse ( %e )", &cexpr);
396 const char *p = gfc_extract_int (cexpr, &collapse);
402 else if (collapse <= 0)
404 gfc_error_now ("COLLAPSE clause argument not"
405 " constant positive integer at %C");
408 c->collapse = collapse;
409 gfc_free_expr (cexpr);
417 if (gfc_match_omp_eos () != MATCH_YES)
419 gfc_free_omp_clauses (c);
427 #define OMP_PARALLEL_CLAUSES \
428 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
429 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IF \
430 | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT)
431 #define OMP_DO_CLAUSES \
432 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
433 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
434 | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE)
435 #define OMP_SECTIONS_CLAUSES \
436 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
437 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
438 #define OMP_TASK_CLAUSES \
439 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
440 | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED)
443 gfc_match_omp_parallel (void)
446 if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES) != MATCH_YES)
448 new_st.op = EXEC_OMP_PARALLEL;
449 new_st.ext.omp_clauses = c;
455 gfc_match_omp_task (void)
458 if (gfc_match_omp_clauses (&c, OMP_TASK_CLAUSES) != MATCH_YES)
460 new_st.op = EXEC_OMP_TASK;
461 new_st.ext.omp_clauses = c;
467 gfc_match_omp_taskwait (void)
469 if (gfc_match_omp_eos () != MATCH_YES)
471 gfc_error ("Unexpected junk after TASKWAIT clause at %C");
474 new_st.op = EXEC_OMP_TASKWAIT;
475 new_st.ext.omp_clauses = NULL;
481 gfc_match_omp_critical (void)
483 char n[GFC_MAX_SYMBOL_LEN+1];
485 if (gfc_match (" ( %n )", n) != MATCH_YES)
487 if (gfc_match_omp_eos () != MATCH_YES)
489 gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
492 new_st.op = EXEC_OMP_CRITICAL;
493 new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
499 gfc_match_omp_do (void)
502 if (gfc_match_omp_clauses (&c, OMP_DO_CLAUSES) != MATCH_YES)
504 new_st.op = EXEC_OMP_DO;
505 new_st.ext.omp_clauses = c;
511 gfc_match_omp_flush (void)
513 gfc_namelist *list = NULL;
514 gfc_match_omp_variable_list (" (", &list, true);
515 if (gfc_match_omp_eos () != MATCH_YES)
517 gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
518 gfc_free_namelist (list);
521 new_st.op = EXEC_OMP_FLUSH;
522 new_st.ext.omp_namelist = list;
528 gfc_match_omp_threadprivate (void)
531 char n[GFC_MAX_SYMBOL_LEN+1];
536 old_loc = gfc_current_locus;
538 m = gfc_match (" (");
544 m = gfc_match_symbol (&sym, 0);
548 if (sym->attr.in_common)
549 gfc_error_now ("Threadprivate variable at %C is an element of "
551 else if (gfc_add_threadprivate (&sym->attr, sym->name,
552 &sym->declared_at) == FAILURE)
561 m = gfc_match (" / %n /", n);
562 if (m == MATCH_ERROR)
564 if (m == MATCH_NO || n[0] == '\0')
567 st = gfc_find_symtree (gfc_current_ns->common_root, n);
570 gfc_error ("COMMON block /%s/ not found at %C", n);
573 st->n.common->threadprivate = 1;
574 for (sym = st->n.common->head; sym; sym = sym->common_next)
575 if (gfc_add_threadprivate (&sym->attr, sym->name,
576 &sym->declared_at) == FAILURE)
580 if (gfc_match_char (')') == MATCH_YES)
582 if (gfc_match_char (',') != MATCH_YES)
589 gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
592 gfc_current_locus = old_loc;
598 gfc_match_omp_parallel_do (void)
601 if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
604 new_st.op = EXEC_OMP_PARALLEL_DO;
605 new_st.ext.omp_clauses = c;
611 gfc_match_omp_parallel_sections (void)
614 if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES)
617 new_st.op = EXEC_OMP_PARALLEL_SECTIONS;
618 new_st.ext.omp_clauses = c;
624 gfc_match_omp_parallel_workshare (void)
627 if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES) != MATCH_YES)
629 new_st.op = EXEC_OMP_PARALLEL_WORKSHARE;
630 new_st.ext.omp_clauses = c;
636 gfc_match_omp_sections (void)
639 if (gfc_match_omp_clauses (&c, OMP_SECTIONS_CLAUSES) != MATCH_YES)
641 new_st.op = EXEC_OMP_SECTIONS;
642 new_st.ext.omp_clauses = c;
648 gfc_match_omp_single (void)
651 if (gfc_match_omp_clauses (&c, OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE)
654 new_st.op = EXEC_OMP_SINGLE;
655 new_st.ext.omp_clauses = c;
661 gfc_match_omp_workshare (void)
663 if (gfc_match_omp_eos () != MATCH_YES)
665 gfc_error ("Unexpected junk after $OMP WORKSHARE statement at %C");
668 new_st.op = EXEC_OMP_WORKSHARE;
669 new_st.ext.omp_clauses = gfc_get_omp_clauses ();
675 gfc_match_omp_master (void)
677 if (gfc_match_omp_eos () != MATCH_YES)
679 gfc_error ("Unexpected junk after $OMP MASTER statement at %C");
682 new_st.op = EXEC_OMP_MASTER;
683 new_st.ext.omp_clauses = NULL;
689 gfc_match_omp_ordered (void)
691 if (gfc_match_omp_eos () != MATCH_YES)
693 gfc_error ("Unexpected junk after $OMP ORDERED statement at %C");
696 new_st.op = EXEC_OMP_ORDERED;
697 new_st.ext.omp_clauses = NULL;
703 gfc_match_omp_atomic (void)
705 if (gfc_match_omp_eos () != MATCH_YES)
707 gfc_error ("Unexpected junk after $OMP ATOMIC statement at %C");
710 new_st.op = EXEC_OMP_ATOMIC;
711 new_st.ext.omp_clauses = NULL;
717 gfc_match_omp_barrier (void)
719 if (gfc_match_omp_eos () != MATCH_YES)
721 gfc_error ("Unexpected junk after $OMP BARRIER statement at %C");
724 new_st.op = EXEC_OMP_BARRIER;
725 new_st.ext.omp_clauses = NULL;
731 gfc_match_omp_end_nowait (void)
734 if (gfc_match ("% nowait") == MATCH_YES)
736 if (gfc_match_omp_eos () != MATCH_YES)
738 gfc_error ("Unexpected junk after NOWAIT clause at %C");
741 new_st.op = EXEC_OMP_END_NOWAIT;
742 new_st.ext.omp_bool = nowait;
748 gfc_match_omp_end_single (void)
751 if (gfc_match ("% nowait") == MATCH_YES)
753 new_st.op = EXEC_OMP_END_NOWAIT;
754 new_st.ext.omp_bool = true;
757 if (gfc_match_omp_clauses (&c, OMP_CLAUSE_COPYPRIVATE) != MATCH_YES)
759 new_st.op = EXEC_OMP_END_SINGLE;
760 new_st.ext.omp_clauses = c;
765 /* OpenMP directive resolving routines. */
768 resolve_omp_clauses (gfc_code *code)
770 gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
773 static const char *clause_names[]
774 = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
775 "COPYIN", "REDUCTION" };
777 if (omp_clauses == NULL)
780 if (omp_clauses->if_expr)
782 gfc_expr *expr = omp_clauses->if_expr;
783 if (gfc_resolve_expr (expr) == FAILURE
784 || expr->ts.type != BT_LOGICAL || expr->rank != 0)
785 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
788 if (omp_clauses->num_threads)
790 gfc_expr *expr = omp_clauses->num_threads;
791 if (gfc_resolve_expr (expr) == FAILURE
792 || expr->ts.type != BT_INTEGER || expr->rank != 0)
793 gfc_error ("NUM_THREADS clause at %L requires a scalar "
794 "INTEGER expression", &expr->where);
796 if (omp_clauses->chunk_size)
798 gfc_expr *expr = omp_clauses->chunk_size;
799 if (gfc_resolve_expr (expr) == FAILURE
800 || expr->ts.type != BT_INTEGER || expr->rank != 0)
801 gfc_error ("SCHEDULE clause's chunk_size at %L requires "
802 "a scalar INTEGER expression", &expr->where);
805 /* Check that no symbol appears on multiple clauses, except that
806 a symbol can appear on both firstprivate and lastprivate. */
807 for (list = 0; list < OMP_LIST_NUM; list++)
808 for (n = omp_clauses->lists[list]; n; n = n->next)
811 if (n->sym->attr.flavor == FL_VARIABLE)
813 if (n->sym->attr.flavor == FL_PROCEDURE
814 && n->sym->result == n->sym
815 && n->sym->attr.function)
817 if (gfc_current_ns->proc_name == n->sym
818 || (gfc_current_ns->parent
819 && gfc_current_ns->parent->proc_name == n->sym))
821 if (gfc_current_ns->proc_name->attr.entry_master)
823 gfc_entry_list *el = gfc_current_ns->entries;
824 for (; el; el = el->next)
825 if (el->sym == n->sym)
830 if (gfc_current_ns->parent
831 && gfc_current_ns->parent->proc_name->attr.entry_master)
833 gfc_entry_list *el = gfc_current_ns->parent->entries;
834 for (; el; el = el->next)
835 if (el->sym == n->sym)
840 if (n->sym->attr.proc_pointer)
843 gfc_error ("Object '%s' is not a variable at %L", n->sym->name,
847 for (list = 0; list < OMP_LIST_NUM; list++)
848 if (list != OMP_LIST_FIRSTPRIVATE && list != OMP_LIST_LASTPRIVATE)
849 for (n = omp_clauses->lists[list]; n; n = n->next)
851 gfc_error ("Symbol '%s' present on multiple clauses at %L",
852 n->sym->name, &code->loc);
856 gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
857 for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++)
858 for (n = omp_clauses->lists[list]; n; n = n->next)
861 gfc_error ("Symbol '%s' present on multiple clauses at %L",
862 n->sym->name, &code->loc);
866 for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
868 gfc_error ("Symbol '%s' present on multiple clauses at %L",
869 n->sym->name, &code->loc);
873 for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
876 for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
878 gfc_error ("Symbol '%s' present on multiple clauses at %L",
879 n->sym->name, &code->loc);
883 for (list = 0; list < OMP_LIST_NUM; list++)
884 if ((n = omp_clauses->lists[list]) != NULL)
888 if (list < OMP_LIST_REDUCTION_FIRST)
889 name = clause_names[list];
890 else if (list <= OMP_LIST_REDUCTION_LAST)
891 name = clause_names[OMP_LIST_REDUCTION_FIRST];
897 case OMP_LIST_COPYIN:
898 for (; n != NULL; n = n->next)
900 if (!n->sym->attr.threadprivate)
901 gfc_error ("Non-THREADPRIVATE object '%s' in COPYIN clause"
902 " at %L", n->sym->name, &code->loc);
903 if (n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
904 gfc_error ("COPYIN clause object '%s' at %L has ALLOCATABLE components",
905 n->sym->name, &code->loc);
908 case OMP_LIST_COPYPRIVATE:
909 for (; n != NULL; n = n->next)
911 if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
912 gfc_error ("Assumed size array '%s' in COPYPRIVATE clause "
913 "at %L", n->sym->name, &code->loc);
914 if (n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
915 gfc_error ("COPYPRIVATE clause object '%s' at %L has ALLOCATABLE components",
916 n->sym->name, &code->loc);
919 case OMP_LIST_SHARED:
920 for (; n != NULL; n = n->next)
922 if (n->sym->attr.threadprivate)
923 gfc_error ("THREADPRIVATE object '%s' in SHARED clause at "
924 "%L", n->sym->name, &code->loc);
925 if (n->sym->attr.cray_pointee)
926 gfc_error ("Cray pointee '%s' in SHARED clause at %L",
927 n->sym->name, &code->loc);
931 for (; n != NULL; n = n->next)
933 if (n->sym->attr.threadprivate)
934 gfc_error ("THREADPRIVATE object '%s' in %s clause at %L",
935 n->sym->name, name, &code->loc);
936 if (n->sym->attr.cray_pointee)
937 gfc_error ("Cray pointee '%s' in %s clause at %L",
938 n->sym->name, name, &code->loc);
939 if (list != OMP_LIST_PRIVATE)
941 if (n->sym->attr.pointer)
942 gfc_error ("POINTER object '%s' in %s clause at %L",
943 n->sym->name, name, &code->loc);
944 /* Variables in REDUCTION-clauses must be of intrinsic type (flagged below). */
945 if ((list < OMP_LIST_REDUCTION_FIRST || list > OMP_LIST_REDUCTION_LAST) &&
946 n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
947 gfc_error ("%s clause object '%s' has ALLOCATABLE components at %L",
948 name, n->sym->name, &code->loc);
949 if (n->sym->attr.cray_pointer)
950 gfc_error ("Cray pointer '%s' in %s clause at %L",
951 n->sym->name, name, &code->loc);
953 if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
954 gfc_error ("Assumed size array '%s' in %s clause at %L",
955 n->sym->name, name, &code->loc);
956 if (n->sym->attr.in_namelist
957 && (list < OMP_LIST_REDUCTION_FIRST
958 || list > OMP_LIST_REDUCTION_LAST))
959 gfc_error ("Variable '%s' in %s clause is used in "
960 "NAMELIST statement at %L",
961 n->sym->name, name, &code->loc);
967 if (!gfc_numeric_ts (&n->sym->ts))
968 gfc_error ("%c REDUCTION variable '%s' at %L must be of numeric type, got %s",
969 list == OMP_LIST_PLUS ? '+'
970 : list == OMP_LIST_MULT ? '*' : '-',
971 n->sym->name, &code->loc,
972 gfc_typename (&n->sym->ts));
978 if (n->sym->ts.type != BT_LOGICAL)
979 gfc_error ("%s REDUCTION variable '%s' must be LOGICAL "
981 list == OMP_LIST_AND ? ".AND."
982 : list == OMP_LIST_OR ? ".OR."
983 : list == OMP_LIST_EQV ? ".EQV." : ".NEQV.",
984 n->sym->name, &code->loc);
988 if (n->sym->ts.type != BT_INTEGER
989 && n->sym->ts.type != BT_REAL)
990 gfc_error ("%s REDUCTION variable '%s' must be "
991 "INTEGER or REAL at %L",
992 list == OMP_LIST_MAX ? "MAX" : "MIN",
993 n->sym->name, &code->loc);
998 if (n->sym->ts.type != BT_INTEGER)
999 gfc_error ("%s REDUCTION variable '%s' must be INTEGER "
1001 list == OMP_LIST_IAND ? "IAND"
1002 : list == OMP_LIST_MULT ? "IOR" : "IEOR",
1003 n->sym->name, &code->loc);
1005 /* Workaround for PR middle-end/26316, nothing really needs
1006 to be done here for OMP_LIST_PRIVATE. */
1007 case OMP_LIST_PRIVATE:
1008 gcc_assert (code->op != EXEC_NOP);
1019 /* Return true if SYM is ever referenced in EXPR except in the SE node. */
1022 expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
1024 gfc_actual_arglist *arg;
1025 if (e == NULL || e == se)
1027 switch (e->expr_type)
1032 case EXPR_STRUCTURE:
1034 if (e->symtree != NULL
1035 && e->symtree->n.sym == s)
1038 case EXPR_SUBSTRING:
1040 && (expr_references_sym (e->ref->u.ss.start, s, se)
1041 || expr_references_sym (e->ref->u.ss.end, s, se)))
1045 if (expr_references_sym (e->value.op.op2, s, se))
1047 return expr_references_sym (e->value.op.op1, s, se);
1049 for (arg = e->value.function.actual; arg; arg = arg->next)
1050 if (expr_references_sym (arg->expr, s, se))
1059 /* If EXPR is a conversion function that widens the type
1060 if WIDENING is true or narrows the type if WIDENING is false,
1061 return the inner expression, otherwise return NULL. */
1064 is_conversion (gfc_expr *expr, bool widening)
1066 gfc_typespec *ts1, *ts2;
1068 if (expr->expr_type != EXPR_FUNCTION
1069 || expr->value.function.isym == NULL
1070 || expr->value.function.esym != NULL
1071 || expr->value.function.isym->id != GFC_ISYM_CONVERSION)
1077 ts2 = &expr->value.function.actual->expr->ts;
1081 ts1 = &expr->value.function.actual->expr->ts;
1085 if (ts1->type > ts2->type
1086 || (ts1->type == ts2->type && ts1->kind > ts2->kind))
1087 return expr->value.function.actual->expr;
1094 resolve_omp_atomic (gfc_code *code)
1099 code = code->block->next;
1100 gcc_assert (code->op == EXEC_ASSIGN);
1101 gcc_assert (code->next == NULL);
1103 if (code->expr1->expr_type != EXPR_VARIABLE
1104 || code->expr1->symtree == NULL
1105 || code->expr1->rank != 0
1106 || (code->expr1->ts.type != BT_INTEGER
1107 && code->expr1->ts.type != BT_REAL
1108 && code->expr1->ts.type != BT_COMPLEX
1109 && code->expr1->ts.type != BT_LOGICAL))
1111 gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
1112 "intrinsic type at %L", &code->loc);
1116 var = code->expr1->symtree->n.sym;
1117 expr2 = is_conversion (code->expr2, false);
1119 expr2 = code->expr2;
1121 if (expr2->expr_type == EXPR_OP)
1123 gfc_expr *v = NULL, *e, *c;
1124 gfc_intrinsic_op op = expr2->value.op.op;
1125 gfc_intrinsic_op alt_op = INTRINSIC_NONE;
1129 case INTRINSIC_PLUS:
1130 alt_op = INTRINSIC_MINUS;
1132 case INTRINSIC_TIMES:
1133 alt_op = INTRINSIC_DIVIDE;
1135 case INTRINSIC_MINUS:
1136 alt_op = INTRINSIC_PLUS;
1138 case INTRINSIC_DIVIDE:
1139 alt_op = INTRINSIC_TIMES;
1145 alt_op = INTRINSIC_NEQV;
1147 case INTRINSIC_NEQV:
1148 alt_op = INTRINSIC_EQV;
1151 gfc_error ("!$OMP ATOMIC assignment operator must be "
1152 "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
1157 /* Check for var = var op expr resp. var = expr op var where
1158 expr doesn't reference var and var op expr is mathematically
1159 equivalent to var op (expr) resp. expr op var equivalent to
1160 (expr) op var. We rely here on the fact that the matcher
1161 for x op1 y op2 z where op1 and op2 have equal precedence
1162 returns (x op1 y) op2 z. */
1163 e = expr2->value.op.op2;
1164 if (e->expr_type == EXPR_VARIABLE
1165 && e->symtree != NULL
1166 && e->symtree->n.sym == var)
1168 else if ((c = is_conversion (e, true)) != NULL
1169 && c->expr_type == EXPR_VARIABLE
1170 && c->symtree != NULL
1171 && c->symtree->n.sym == var)
1175 gfc_expr **p = NULL, **q;
1176 for (q = &expr2->value.op.op1; (e = *q) != NULL; )
1177 if (e->expr_type == EXPR_VARIABLE
1178 && e->symtree != NULL
1179 && e->symtree->n.sym == var)
1184 else if ((c = is_conversion (e, true)) != NULL)
1185 q = &e->value.function.actual->expr;
1186 else if (e->expr_type != EXPR_OP
1187 || (e->value.op.op != op
1188 && e->value.op.op != alt_op)
1194 q = &e->value.op.op1;
1199 gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
1200 "or var = expr op var at %L", &expr2->where);
1207 switch (e->value.op.op)
1209 case INTRINSIC_MINUS:
1210 case INTRINSIC_DIVIDE:
1212 case INTRINSIC_NEQV:
1213 gfc_error ("!$OMP ATOMIC var = var op expr not "
1214 "mathematically equivalent to var = var op "
1215 "(expr) at %L", &expr2->where);
1221 /* Canonicalize into var = var op (expr). */
1222 *p = e->value.op.op2;
1223 e->value.op.op2 = expr2;
1225 if (code->expr2 == expr2)
1226 code->expr2 = expr2 = e;
1228 code->expr2->value.function.actual->expr = expr2 = e;
1230 if (!gfc_compare_types (&expr2->value.op.op1->ts, &expr2->ts))
1232 for (p = &expr2->value.op.op1; *p != v;
1233 p = &(*p)->value.function.actual->expr)
1236 gfc_free_expr (expr2->value.op.op1);
1237 expr2->value.op.op1 = v;
1238 gfc_convert_type (v, &expr2->ts, 2);
1243 if (e->rank != 0 || expr_references_sym (code->expr2, var, v))
1245 gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
1246 "must be scalar and cannot reference var at %L",
1251 else if (expr2->expr_type == EXPR_FUNCTION
1252 && expr2->value.function.isym != NULL
1253 && expr2->value.function.esym == NULL
1254 && expr2->value.function.actual != NULL
1255 && expr2->value.function.actual->next != NULL)
1257 gfc_actual_arglist *arg, *var_arg;
1259 switch (expr2->value.function.isym->id)
1267 if (expr2->value.function.actual->next->next != NULL)
1269 gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
1270 "or IEOR must have two arguments at %L",
1276 gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
1277 "MIN, MAX, IAND, IOR or IEOR at %L",
1283 for (arg = expr2->value.function.actual; arg; arg = arg->next)
1285 if ((arg == expr2->value.function.actual
1286 || (var_arg == NULL && arg->next == NULL))
1287 && arg->expr->expr_type == EXPR_VARIABLE
1288 && arg->expr->symtree != NULL
1289 && arg->expr->symtree->n.sym == var)
1291 else if (expr_references_sym (arg->expr, var, NULL))
1292 gfc_error ("!$OMP ATOMIC intrinsic arguments except one must not "
1293 "reference '%s' at %L", var->name, &arg->expr->where);
1294 if (arg->expr->rank != 0)
1295 gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
1296 "at %L", &arg->expr->where);
1299 if (var_arg == NULL)
1301 gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
1302 "be '%s' at %L", var->name, &expr2->where);
1306 if (var_arg != expr2->value.function.actual)
1308 /* Canonicalize, so that var comes first. */
1309 gcc_assert (var_arg->next == NULL);
1310 for (arg = expr2->value.function.actual;
1311 arg->next != var_arg; arg = arg->next)
1313 var_arg->next = expr2->value.function.actual;
1314 expr2->value.function.actual = var_arg;
1319 gfc_error ("!$OMP ATOMIC assignment must have an operator or intrinsic "
1320 "on right hand side at %L", &expr2->where);
1327 struct pointer_set_t *sharing_clauses;
1328 struct pointer_set_t *private_iterators;
1329 struct omp_context *previous;
1331 static gfc_code *omp_current_do_code;
1332 static int omp_current_do_collapse;
1335 gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
1337 if (code->block->next && code->block->next->op == EXEC_DO)
1342 omp_current_do_code = code->block->next;
1343 omp_current_do_collapse = code->ext.omp_clauses->collapse;
1344 for (i = 1, c = omp_current_do_code; i < omp_current_do_collapse; i++)
1347 if (c->op != EXEC_DO || c->next == NULL)
1350 if (c->op != EXEC_DO)
1353 if (i < omp_current_do_collapse || omp_current_do_collapse <= 0)
1354 omp_current_do_collapse = 1;
1356 gfc_resolve_blocks (code->block, ns);
1357 omp_current_do_collapse = 0;
1358 omp_current_do_code = NULL;
1363 gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
1365 struct omp_context ctx;
1366 gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
1371 ctx.sharing_clauses = pointer_set_create ();
1372 ctx.private_iterators = pointer_set_create ();
1373 ctx.previous = omp_current_ctx;
1374 omp_current_ctx = &ctx;
1376 for (list = 0; list < OMP_LIST_NUM; list++)
1377 for (n = omp_clauses->lists[list]; n; n = n->next)
1378 pointer_set_insert (ctx.sharing_clauses, n->sym);
1380 if (code->op == EXEC_OMP_PARALLEL_DO)
1381 gfc_resolve_omp_do_blocks (code, ns);
1383 gfc_resolve_blocks (code->block, ns);
1385 omp_current_ctx = ctx.previous;
1386 pointer_set_destroy (ctx.sharing_clauses);
1387 pointer_set_destroy (ctx.private_iterators);
1391 /* Note a DO iterator variable. This is special in !$omp parallel
1392 construct, where they are predetermined private. */
1395 gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym)
1397 int i = omp_current_do_collapse;
1398 gfc_code *c = omp_current_do_code;
1400 if (sym->attr.threadprivate)
1403 /* !$omp do and !$omp parallel do iteration variable is predetermined
1404 private just in the !$omp do resp. !$omp parallel do construct,
1405 with no implications for the outer parallel constructs. */
1415 if (omp_current_ctx == NULL)
1418 if (pointer_set_contains (omp_current_ctx->sharing_clauses, sym))
1421 if (! pointer_set_insert (omp_current_ctx->private_iterators, sym))
1423 gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
1426 p = gfc_get_namelist ();
1428 p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
1429 omp_clauses->lists[OMP_LIST_PRIVATE] = p;
1435 resolve_omp_do (gfc_code *code)
1437 gfc_code *do_code, *c;
1438 int list, i, collapse;
1442 if (code->ext.omp_clauses)
1443 resolve_omp_clauses (code);
1445 do_code = code->block->next;
1446 collapse = code->ext.omp_clauses->collapse;
1449 for (i = 1; i <= collapse; i++)
1451 if (do_code->op == EXEC_DO_WHILE)
1453 gfc_error ("!$OMP DO cannot be a DO WHILE or DO without loop control "
1454 "at %L", &do_code->loc);
1457 gcc_assert (do_code->op == EXEC_DO);
1458 if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
1459 gfc_error ("!$OMP DO iteration variable must be of type integer at %L",
1461 dovar = do_code->ext.iterator->var->symtree->n.sym;
1462 if (dovar->attr.threadprivate)
1463 gfc_error ("!$OMP DO iteration variable must not be THREADPRIVATE "
1464 "at %L", &do_code->loc);
1465 if (code->ext.omp_clauses)
1466 for (list = 0; list < OMP_LIST_NUM; list++)
1467 if (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE)
1468 for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
1469 if (dovar == n->sym)
1471 gfc_error ("!$OMP DO iteration variable present on clause "
1472 "other than PRIVATE or LASTPRIVATE at %L",
1478 gfc_code *do_code2 = code->block->next;
1481 for (j = 1; j < i; j++)
1483 gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
1485 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
1486 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
1487 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
1489 gfc_error ("!$OMP DO collapsed loops don't form rectangular iteration space at %L",
1495 do_code2 = do_code2->block->next;
1500 for (c = do_code->next; c; c = c->next)
1501 if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
1503 gfc_error ("collapsed !$OMP DO loops not perfectly nested at %L",
1509 do_code = do_code->block;
1510 if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)
1512 gfc_error ("not enough DO loops for collapsed !$OMP DO at %L",
1516 do_code = do_code->next;
1517 if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)
1519 gfc_error ("not enough DO loops for collapsed !$OMP DO at %L",
1527 /* Resolve OpenMP directive clauses and check various requirements
1528 of each directive. */
1531 gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
1533 if (code->op != EXEC_OMP_ATOMIC)
1534 gfc_maybe_initialize_eh ();
1539 case EXEC_OMP_PARALLEL_DO:
1540 resolve_omp_do (code);
1542 case EXEC_OMP_WORKSHARE:
1543 case EXEC_OMP_PARALLEL_WORKSHARE:
1544 case EXEC_OMP_PARALLEL:
1545 case EXEC_OMP_PARALLEL_SECTIONS:
1546 case EXEC_OMP_SECTIONS:
1547 case EXEC_OMP_SINGLE:
1548 if (code->ext.omp_clauses)
1549 resolve_omp_clauses (code);
1551 case EXEC_OMP_ATOMIC:
1552 resolve_omp_atomic (code);