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