gcc/fortran/openmp.c

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