gcc/fortran/openmp.c

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