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         if (n->sym->mark)
 849           gfc_error ("Symbol '%s' present on multiple clauses at %L",
 850                      n->sym->name, &code->loc);
 851         else
 852           n->sym->mark = 1;
 853
 854   gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
 855   for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++)
 856     for (n = omp_clauses->lists[list]; n; n = n->next)
 857       if (n->sym->mark)
 858         {
 859           gfc_error ("Symbol '%s' present on multiple clauses at %L",
 860                      n->sym->name, &code->loc);
 861           n->sym->mark = 0;
 862         }
 863
 864   for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
 865     if (n->sym->mark)
 866       gfc_error ("Symbol '%s' present on multiple clauses at %L",
 867                  n->sym->name, &code->loc);
 868     else
 869       n->sym->mark = 1;
 870
 871   for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
 872     n->sym->mark = 0;
 873
 874   for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
 875     if (n->sym->mark)
 876       gfc_error ("Symbol '%s' present on multiple clauses at %L",
 877                  n->sym->name, &code->loc);
 878     else
 879       n->sym->mark = 1;
 880
 881   for (list = 0; list < OMP_LIST_NUM; list++)
 882     if ((n = omp_clauses->lists[list]) != NULL)
 883       {
 884         const char *name;
 885
 886         if (list < OMP_LIST_REDUCTION_FIRST)
 887           name = clause_names[list];
 888         else if (list <= OMP_LIST_REDUCTION_LAST)
 889           name = clause_names[OMP_LIST_REDUCTION_FIRST];
 890         else
 891           gcc_unreachable ();
 892
 893         switch (list)
 894           {
 895           case OMP_LIST_COPYIN:
 896             for (; n != NULL; n = n->next)
 897               {
 898                 if (!n->sym->attr.threadprivate)
 899                   gfc_error ("Non-THREADPRIVATE object '%s' in COPYIN clause"
 900                              " at %L", n->sym->name, &code->loc);
 901                 if (n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
 902                   gfc_error ("COPYIN clause object '%s' at %L has ALLOCATABLE components",
 903                              n->sym->name, &code->loc);
 904               }
 905             break;
 906           case OMP_LIST_COPYPRIVATE:
 907             for (; n != NULL; n = n->next)
 908               {
 909                 if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
 910                   gfc_error ("Assumed size array '%s' in COPYPRIVATE clause "
 911                              "at %L", n->sym->name, &code->loc);
 912                 if (n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
 913                   gfc_error ("COPYPRIVATE clause object '%s' at %L has ALLOCATABLE components",
 914                              n->sym->name, &code->loc);
 915               }
 916             break;
 917           case OMP_LIST_SHARED:
 918             for (; n != NULL; n = n->next)
 919               {
 920                 if (n->sym->attr.threadprivate)
 921                   gfc_error ("THREADPRIVATE object '%s' in SHARED clause at "
 922                              "%L", n->sym->name, &code->loc);
 923                 if (n->sym->attr.cray_pointee)
 924                   gfc_error ("Cray pointee '%s' in SHARED clause at %L",
 925                             n->sym->name, &code->loc);
 926               }
 927             break;
 928           default:
 929             for (; n != NULL; n = n->next)
 930               {
 931                 if (n->sym->attr.threadprivate)
 932                   gfc_error ("THREADPRIVATE object '%s' in %s clause at %L",
 933                              n->sym->name, name, &code->loc);
 934                 if (n->sym->attr.cray_pointee)
 935                   gfc_error ("Cray pointee '%s' in %s clause at %L",
 936                             n->sym->name, name, &code->loc);
 937                 if (list != OMP_LIST_PRIVATE)
 938                   {
 939                     if (n->sym->attr.pointer)
 940                       gfc_error ("POINTER object '%s' in %s clause at %L",
 941                                  n->sym->name, name, &code->loc);
 942                     /* Variables in REDUCTION-clauses must be of intrinsic type (flagged below).  */
 943                     if ((list < OMP_LIST_REDUCTION_FIRST || list > OMP_LIST_REDUCTION_LAST) &&
 944                         n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
 945                       gfc_error ("%s clause object '%s' has ALLOCATABLE components at %L",
 946                                  name, n->sym->name, &code->loc);
 947                     if (n->sym->attr.cray_pointer)
 948                       gfc_error ("Cray pointer '%s' in %s clause at %L",
 949                                  n->sym->name, name, &code->loc);
 950                   }
 951                 if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
 952                   gfc_error ("Assumed size array '%s' in %s clause at %L",
 953                              n->sym->name, name, &code->loc);
 954                 if (n->sym->attr.in_namelist
 955                     && (list < OMP_LIST_REDUCTION_FIRST
 956                         || list > OMP_LIST_REDUCTION_LAST))
 957                   gfc_error ("Variable '%s' in %s clause is used in "
 958                              "NAMELIST statement at %L",
 959                              n->sym->name, name, &code->loc);
 960                 switch (list)
 961                   {
 962                   case OMP_LIST_PLUS:
 963                   case OMP_LIST_MULT:
 964                   case OMP_LIST_SUB:
 965                     if (!gfc_numeric_ts (&n->sym->ts))
 966                       gfc_error ("%c REDUCTION variable '%s' at %L must be of numeric type, got %s",
 967                                  list == OMP_LIST_PLUS ? '+'
 968                                  : list == OMP_LIST_MULT ? '*' : '-',
 969                                  n->sym->name, &code->loc,
 970                                  gfc_typename (&n->sym->ts));
 971                     break;
 972                   case OMP_LIST_AND:
 973                   case OMP_LIST_OR:
 974                   case OMP_LIST_EQV:
 975                   case OMP_LIST_NEQV:
 976                     if (n->sym->ts.type != BT_LOGICAL)
 977                       gfc_error ("%s REDUCTION variable '%s' must be LOGICAL "
 978                                  "at %L",
 979                                  list == OMP_LIST_AND ? ".AND."
 980                                  : list == OMP_LIST_OR ? ".OR."
 981                                  : list == OMP_LIST_EQV ? ".EQV." : ".NEQV.",
 982                                  n->sym->name, &code->loc);
 983                     break;
 984                   case OMP_LIST_MAX:
 985                   case OMP_LIST_MIN:
 986                     if (n->sym->ts.type != BT_INTEGER
 987                         && n->sym->ts.type != BT_REAL)
 988                       gfc_error ("%s REDUCTION variable '%s' must be "
 989                                  "INTEGER or REAL at %L",
 990                                  list == OMP_LIST_MAX ? "MAX" : "MIN",
 991                                  n->sym->name, &code->loc);
 992                     break;
 993                   case OMP_LIST_IAND:
 994                   case OMP_LIST_IOR:
 995                   case OMP_LIST_IEOR:
 996                     if (n->sym->ts.type != BT_INTEGER)
 997                       gfc_error ("%s REDUCTION variable '%s' must be INTEGER "
 998                                  "at %L",
 999                                  list == OMP_LIST_IAND ? "IAND"
1000                                  : list == OMP_LIST_MULT ? "IOR" : "IEOR",
1001                                  n->sym->name, &code->loc);
1002                     break;
1003                   /* Workaround for PR middle-end/26316, nothing really needs
1004                      to be done here for OMP_LIST_PRIVATE.  */
1005                   case OMP_LIST_PRIVATE:
1006                     gcc_assert (code->op != EXEC_NOP);
1007                   default:
1008                     break;
1009                   }
1010               }
1011             break;
1012           }
1013       }
1014 }
1015
1016
1017 /* Return true if SYM is ever referenced in EXPR except in the SE node.  */
1018
1019 static bool
1020 expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
1021 {
1022   gfc_actual_arglist *arg;
1023   if (e == NULL || e == se)
1024     return false;
1025   switch (e->expr_type)
1026     {
1027     case EXPR_CONSTANT:
1028     case EXPR_NULL:
1029     case EXPR_VARIABLE:
1030     case EXPR_STRUCTURE:
1031     case EXPR_ARRAY:
1032       if (e->symtree != NULL
1033           && e->symtree->n.sym == s)
1034         return true;
1035       return false;
1036     case EXPR_SUBSTRING:
1037       if (e->ref != NULL
1038           && (expr_references_sym (e->ref->u.ss.start, s, se)
1039               || expr_references_sym (e->ref->u.ss.end, s, se)))
1040         return true;
1041       return false;
1042     case EXPR_OP:
1043       if (expr_references_sym (e->value.op.op2, s, se))
1044         return true;
1045       return expr_references_sym (e->value.op.op1, s, se);
1046     case EXPR_FUNCTION:
1047       for (arg = e->value.function.actual; arg; arg = arg->next)
1048         if (expr_references_sym (arg->expr, s, se))
1049           return true;
1050       return false;
1051     default:
1052       gcc_unreachable ();
1053     }
1054 }
1055
1056
1057 /* If EXPR is a conversion function that widens the type
1058    if WIDENING is true or narrows the type if WIDENING is false,
1059    return the inner expression, otherwise return NULL.  */
1060
1061 static gfc_expr *
1062 is_conversion (gfc_expr *expr, bool widening)
1063 {
1064   gfc_typespec *ts1, *ts2;
1065
1066   if (expr->expr_type != EXPR_FUNCTION
1067       || expr->value.function.isym == NULL
1068       || expr->value.function.esym != NULL
1069       || expr->value.function.isym->id != GFC_ISYM_CONVERSION)
1070     return NULL;
1071
1072   if (widening)
1073     {
1074       ts1 = &expr->ts;
1075       ts2 = &expr->value.function.actual->expr->ts;
1076     }
1077   else
1078     {
1079       ts1 = &expr->value.function.actual->expr->ts;
1080       ts2 = &expr->ts;
1081     }
1082
1083   if (ts1->type > ts2->type
1084       || (ts1->type == ts2->type && ts1->kind > ts2->kind))
1085     return expr->value.function.actual->expr;
1086
1087   return NULL;
1088 }
1089
1090
1091 static void
1092 resolve_omp_atomic (gfc_code *code)
1093 {
1094   gfc_symbol *var;
1095   gfc_expr *expr2;
1096
1097   code = code->block->next;
1098   gcc_assert (code->op == EXEC_ASSIGN);
1099   gcc_assert (code->next == NULL);
1100
1101   if (code->expr1->expr_type != EXPR_VARIABLE
1102       || code->expr1->symtree == NULL
1103       || code->expr1->rank != 0
1104       || (code->expr1->ts.type != BT_INTEGER
1105           && code->expr1->ts.type != BT_REAL
1106           && code->expr1->ts.type != BT_COMPLEX
1107           && code->expr1->ts.type != BT_LOGICAL))
1108     {
1109       gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
1110                  "intrinsic type at %L", &code->loc);
1111       return;
1112     }
1113
1114   var = code->expr1->symtree->n.sym;
1115   expr2 = is_conversion (code->expr2, false);
1116   if (expr2 == NULL)
1117     expr2 = code->expr2;
1118
1119   if (expr2->expr_type == EXPR_OP)
1120     {
1121       gfc_expr *v = NULL, *e, *c;
1122       gfc_intrinsic_op op = expr2->value.op.op;
1123       gfc_intrinsic_op alt_op = INTRINSIC_NONE;
1124
1125       switch (op)
1126         {
1127         case INTRINSIC_PLUS:
1128           alt_op = INTRINSIC_MINUS;
1129           break;
1130         case INTRINSIC_TIMES:
1131           alt_op = INTRINSIC_DIVIDE;
1132           break;
1133         case INTRINSIC_MINUS:
1134           alt_op = INTRINSIC_PLUS;
1135           break;
1136         case INTRINSIC_DIVIDE:
1137           alt_op = INTRINSIC_TIMES;
1138           break;
1139         case INTRINSIC_AND:
1140         case INTRINSIC_OR:
1141           break;
1142         case INTRINSIC_EQV:
1143           alt_op = INTRINSIC_NEQV;
1144           break;
1145         case INTRINSIC_NEQV:
1146           alt_op = INTRINSIC_EQV;
1147           break;
1148         default:
1149           gfc_error ("!$OMP ATOMIC assignment operator must be "
1150                      "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
1151                      &expr2->where);
1152           return;
1153         }
1154
1155       /* Check for var = var op expr resp. var = expr op var where
1156          expr doesn't reference var and var op expr is mathematically
1157          equivalent to var op (expr) resp. expr op var equivalent to
1158          (expr) op var.  We rely here on the fact that the matcher
1159          for x op1 y op2 z where op1 and op2 have equal precedence
1160          returns (x op1 y) op2 z.  */
1161       e = expr2->value.op.op2;
1162       if (e->expr_type == EXPR_VARIABLE
1163           && e->symtree != NULL
1164           && e->symtree->n.sym == var)
1165         v = e;
1166       else if ((c = is_conversion (e, true)) != NULL
1167                && c->expr_type == EXPR_VARIABLE
1168                && c->symtree != NULL
1169                && c->symtree->n.sym == var)
1170         v = c;
1171       else
1172         {
1173           gfc_expr **p = NULL, **q;
1174           for (q = &expr2->value.op.op1; (e = *q) != NULL; )
1175             if (e->expr_type == EXPR_VARIABLE
1176                 && e->symtree != NULL
1177                 && e->symtree->n.sym == var)
1178               {
1179                 v = e;
1180                 break;
1181               }
1182             else if ((c = is_conversion (e, true)) != NULL)
1183               q = &e->value.function.actual->expr;
1184             else if (e->expr_type != EXPR_OP
1185                      || (e->value.op.op != op
1186                          && e->value.op.op != alt_op)
1187                      || e->rank != 0)
1188               break;
1189             else
1190               {
1191                 p = q;
1192                 q = &e->value.op.op1;
1193               }
1194
1195           if (v == NULL)
1196             {
1197               gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
1198                          "or var = expr op var at %L", &expr2->where);
1199               return;
1200             }
1201
1202           if (p != NULL)
1203             {
1204               e = *p;
1205               switch (e->value.op.op)
1206                 {
1207                 case INTRINSIC_MINUS:
1208                 case INTRINSIC_DIVIDE:
1209                 case INTRINSIC_EQV:
1210                 case INTRINSIC_NEQV:
1211                   gfc_error ("!$OMP ATOMIC var = var op expr not "
1212                              "mathematically equivalent to var = var op "
1213                              "(expr) at %L", &expr2->where);
1214                   break;
1215                 default:
1216                   break;
1217                 }
1218
1219               /* Canonicalize into var = var op (expr).  */
1220               *p = e->value.op.op2;
1221               e->value.op.op2 = expr2;
1222               e->ts = expr2->ts;
1223               if (code->expr2 == expr2)
1224                 code->expr2 = expr2 = e;
1225               else
1226                 code->expr2->value.function.actual->expr = expr2 = e;
1227
1228               if (!gfc_compare_types (&expr2->value.op.op1->ts, &expr2->ts))
1229                 {
1230                   for (p = &expr2->value.op.op1; *p != v;
1231                        p = &(*p)->value.function.actual->expr)
1232                     ;
1233                   *p = NULL;
1234                   gfc_free_expr (expr2->value.op.op1);
1235                   expr2->value.op.op1 = v;
1236                   gfc_convert_type (v, &expr2->ts, 2);
1237                 }
1238             }
1239         }
1240
1241       if (e->rank != 0 || expr_references_sym (code->expr2, var, v))
1242         {
1243           gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
1244                      "must be scalar and cannot reference var at %L",
1245                      &expr2->where);
1246           return;
1247         }
1248     }
1249   else if (expr2->expr_type == EXPR_FUNCTION
1250            && expr2->value.function.isym != NULL
1251            && expr2->value.function.esym == NULL
1252            && expr2->value.function.actual != NULL
1253            && expr2->value.function.actual->next != NULL)
1254     {
1255       gfc_actual_arglist *arg, *var_arg;
1256
1257       switch (expr2->value.function.isym->id)
1258         {
1259         case GFC_ISYM_MIN:
1260         case GFC_ISYM_MAX:
1261           break;
1262         case GFC_ISYM_IAND:
1263         case GFC_ISYM_IOR:
1264         case GFC_ISYM_IEOR:
1265           if (expr2->value.function.actual->next->next != NULL)
1266             {
1267               gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
1268                          "or IEOR must have two arguments at %L",
1269                          &expr2->where);
1270               return;
1271             }
1272           break;
1273         default:
1274           gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
1275                      "MIN, MAX, IAND, IOR or IEOR at %L",
1276                      &expr2->where);
1277           return;
1278         }
1279
1280       var_arg = NULL;
1281       for (arg = expr2->value.function.actual; arg; arg = arg->next)
1282         {
1283           if ((arg == expr2->value.function.actual
1284                || (var_arg == NULL && arg->next == NULL))
1285               && arg->expr->expr_type == EXPR_VARIABLE
1286               && arg->expr->symtree != NULL
1287               && arg->expr->symtree->n.sym == var)
1288             var_arg = arg;
1289           else if (expr_references_sym (arg->expr, var, NULL))
1290             gfc_error ("!$OMP ATOMIC intrinsic arguments except one must not "
1291                        "reference '%s' at %L", var->name, &arg->expr->where);
1292           if (arg->expr->rank != 0)
1293             gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
1294                        "at %L", &arg->expr->where);
1295         }
1296
1297       if (var_arg == NULL)
1298         {
1299           gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
1300                      "be '%s' at %L", var->name, &expr2->where);
1301           return;
1302         }
1303
1304       if (var_arg != expr2->value.function.actual)
1305         {
1306           /* Canonicalize, so that var comes first.  */
1307           gcc_assert (var_arg->next == NULL);
1308           for (arg = expr2->value.function.actual;
1309                arg->next != var_arg; arg = arg->next)
1310             ;
1311           var_arg->next = expr2->value.function.actual;
1312           expr2->value.function.actual = var_arg;
1313           arg->next = NULL;
1314         }
1315     }
1316   else
1317     gfc_error ("!$OMP ATOMIC assignment must have an operator or intrinsic "
1318                "on right hand side at %L", &expr2->where);
1319 }
1320
1321
1322 struct omp_context
1323 {
1324   gfc_code *code;
1325   struct pointer_set_t *sharing_clauses;
1326   struct pointer_set_t *private_iterators;
1327   struct omp_context *previous;
1328 } *omp_current_ctx;
1329 static gfc_code *omp_current_do_code;
1330 static int omp_current_do_collapse;
1331
1332 void
1333 gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
1334 {
1335   if (code->block->next && code->block->next->op == EXEC_DO)
1336     {
1337       int i;
1338       gfc_code *c;
1339
1340       omp_current_do_code = code->block->next;
1341       omp_current_do_collapse = code->ext.omp_clauses->collapse;
1342       for (i = 1, c = omp_current_do_code; i < omp_current_do_collapse; i++)
1343         {
1344           c = c->block;
1345           if (c->op != EXEC_DO || c->next == NULL)
1346             break;
1347           c = c->next;
1348           if (c->op != EXEC_DO)
1349             break;
1350         }
1351       if (i < omp_current_do_collapse || omp_current_do_collapse <= 0)
1352         omp_current_do_collapse = 1;
1353     }
1354   gfc_resolve_blocks (code->block, ns);
1355   omp_current_do_collapse = 0;
1356   omp_current_do_code = NULL;
1357 }
1358
1359
1360 void
1361 gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
1362 {
1363   struct omp_context ctx;
1364   gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
1365   gfc_namelist *n;
1366   int list;
1367
1368   ctx.code = code;
1369   ctx.sharing_clauses = pointer_set_create ();
1370   ctx.private_iterators = pointer_set_create ();
1371   ctx.previous = omp_current_ctx;
1372   omp_current_ctx = &ctx;
1373
1374   for (list = 0; list < OMP_LIST_NUM; list++)
1375     for (n = omp_clauses->lists[list]; n; n = n->next)
1376       pointer_set_insert (ctx.sharing_clauses, n->sym);
1377
1378   if (code->op == EXEC_OMP_PARALLEL_DO)
1379     gfc_resolve_omp_do_blocks (code, ns);
1380   else
1381     gfc_resolve_blocks (code->block, ns);
1382
1383   omp_current_ctx = ctx.previous;
1384   pointer_set_destroy (ctx.sharing_clauses);
1385   pointer_set_destroy (ctx.private_iterators);
1386 }
1387
1388
1389 /* Note a DO iterator variable.  This is special in !$omp parallel
1390    construct, where they are predetermined private.  */
1391
1392 void
1393 gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym)
1394 {
1395   int i = omp_current_do_collapse;
1396   gfc_code *c = omp_current_do_code;
1397
1398   if (sym->attr.threadprivate)
1399     return;
1400
1401   /* !$omp do and !$omp parallel do iteration variable is predetermined
1402      private just in the !$omp do resp. !$omp parallel do construct,
1403      with no implications for the outer parallel constructs.  */
1404
1405   while (i-- >= 1)
1406     {
1407       if (code == c)
1408         return;
1409
1410       c = c->block->next;
1411     }
1412
1413   if (omp_current_ctx == NULL)
1414     return;
1415
1416   if (pointer_set_contains (omp_current_ctx->sharing_clauses, sym))
1417     return;
1418
1419   if (! pointer_set_insert (omp_current_ctx->private_iterators, sym))
1420     {
1421       gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
1422       gfc_namelist *p;
1423
1424       p = gfc_get_namelist ();
1425       p->sym = sym;
1426       p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
1427       omp_clauses->lists[OMP_LIST_PRIVATE] = p;
1428     }
1429 }
1430
1431
1432 static void
1433 resolve_omp_do (gfc_code *code)
1434 {
1435   gfc_code *do_code, *c;
1436   int list, i, collapse;
1437   gfc_namelist *n;
1438   gfc_symbol *dovar;
1439
1440   if (code->ext.omp_clauses)
1441     resolve_omp_clauses (code);
1442
1443   do_code = code->block->next;
1444   collapse = code->ext.omp_clauses->collapse;
1445   if (collapse <= 0)
1446     collapse = 1;
1447   for (i = 1; i <= collapse; i++)
1448     {
1449       if (do_code->op == EXEC_DO_WHILE)
1450         {
1451           gfc_error ("!$OMP DO cannot be a DO WHILE or DO without loop control "
1452                      "at %L", &do_code->loc);
1453           break;
1454         }
1455       gcc_assert (do_code->op == EXEC_DO);
1456       if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
1457         gfc_error ("!$OMP DO iteration variable must be of type integer at %L",
1458                    &do_code->loc);
1459       dovar = do_code->ext.iterator->var->symtree->n.sym;
1460       if (dovar->attr.threadprivate)
1461         gfc_error ("!$OMP DO iteration variable must not be THREADPRIVATE "
1462                    "at %L", &do_code->loc);
1463       if (code->ext.omp_clauses)
1464         for (list = 0; list < OMP_LIST_NUM; list++)
1465           if (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE)
1466             for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
1467               if (dovar == n->sym)
1468                 {
1469                   gfc_error ("!$OMP DO iteration variable present on clause "
1470                              "other than PRIVATE or LASTPRIVATE at %L",
1471                              &do_code->loc);
1472                   break;
1473                 }
1474       if (i > 1)
1475         {
1476           gfc_code *do_code2 = code->block->next;
1477           int j;
1478
1479           for (j = 1; j < i; j++)
1480             {
1481               gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
1482               if (dovar == ivar
1483                   || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
1484                   || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
1485                   || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
1486                 {
1487                   gfc_error ("!$OMP DO collapsed loops don't form rectangular iteration space at %L",
1488                              &do_code->loc);
1489                   break;
1490                 }
1491               if (j < i)
1492                 break;
1493               do_code2 = do_code2->block->next;
1494             }
1495         }
1496       if (i == collapse)
1497         break;
1498       for (c = do_code->next; c; c = c->next)
1499         if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
1500           {
1501             gfc_error ("collapsed !$OMP DO loops not perfectly nested at %L",
1502                        &c->loc);
1503             break;
1504           }
1505       if (c)
1506         break;
1507       do_code = do_code->block;
1508       if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)
1509         {
1510           gfc_error ("not enough DO loops for collapsed !$OMP DO at %L",
1511                      &code->loc);
1512           break;
1513         }
1514       do_code = do_code->next;
1515       if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)
1516         {
1517           gfc_error ("not enough DO loops for collapsed !$OMP DO at %L",
1518                      &code->loc);
1519           break;
1520         }
1521     }
1522 }
1523
1524
1525 /* Resolve OpenMP directive clauses and check various requirements
1526    of each directive.  */
1527
1528 void
1529 gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
1530 {
1531   if (code->op != EXEC_OMP_ATOMIC)
1532     gfc_maybe_initialize_eh ();
1533
1534   switch (code->op)
1535     {
1536     case EXEC_OMP_DO:
1537     case EXEC_OMP_PARALLEL_DO:
1538       resolve_omp_do (code);
1539       break;
1540     case EXEC_OMP_WORKSHARE:
1541     case EXEC_OMP_PARALLEL_WORKSHARE:
1542     case EXEC_OMP_PARALLEL:
1543     case EXEC_OMP_PARALLEL_SECTIONS:
1544     case EXEC_OMP_SECTIONS:
1545     case EXEC_OMP_SINGLE:
1546       if (code->ext.omp_clauses)
1547         resolve_omp_clauses (code);
1548       break;
1549     case EXEC_OMP_ATOMIC:
1550       resolve_omp_atomic (code);
1551       break;
1552     default:
1553       break;
1554     }
1555 }