gcc/fortran/openmp.c

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