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