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