gcc/fortran/openmp.c

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