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