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