OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [fortran/] [openmp.c] - Blame information for rev 285

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.