gcc/fortran/openmp.c

   1 /* OpenMP directive matching and resolving.
   2    Copyright (C) 2005, 2006, 2007
   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   int c;
  40
  41   old_loc = gfc_current_locus;
  42   gfc_gobble_whitespace ();
  43
  44   c = gfc_next_char ();
  45   switch (c)
  46     {
  47     case '!':
  48       do
  49         c = gfc_next_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
 186 /* Match OpenMP directive clauses. MASK is a bitmask of
 187    clauses that are allowed for a particular directive.  */
 188
 189 static match
 190 gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask)
 191 {
 192   gfc_omp_clauses *c = gfc_get_omp_clauses ();
 193   locus old_loc;
 194   bool needs_space = true, first = true;
 195
 196   *cp = NULL;
 197   while (1)
 198     {
 199       if ((first || gfc_match_char (',') != MATCH_YES)
 200           && (needs_space && gfc_match_space () != MATCH_YES))
 201         break;
 202       needs_space = false;
 203       first = false;
 204       gfc_gobble_whitespace ();
 205       if ((mask & OMP_CLAUSE_IF) && c->if_expr == NULL
 206           && gfc_match ("if ( %e )", &c->if_expr) == MATCH_YES)
 207         continue;
 208       if ((mask & OMP_CLAUSE_NUM_THREADS) && c->num_threads == NULL
 209           && gfc_match ("num_threads ( %e )", &c->num_threads) == MATCH_YES)
 210         continue;
 211       if ((mask & OMP_CLAUSE_PRIVATE)
 212           && gfc_match_omp_variable_list ("private (",
 213                                           &c->lists[OMP_LIST_PRIVATE], true)
 214              == MATCH_YES)
 215         continue;
 216       if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
 217           && gfc_match_omp_variable_list ("firstprivate (",
 218                                           &c->lists[OMP_LIST_FIRSTPRIVATE],
 219                                           true)
 220              == MATCH_YES)
 221         continue;
 222       if ((mask & OMP_CLAUSE_LASTPRIVATE)
 223           && gfc_match_omp_variable_list ("lastprivate (",
 224                                           &c->lists[OMP_LIST_LASTPRIVATE],
 225                                           true)
 226              == MATCH_YES)
 227         continue;
 228       if ((mask & OMP_CLAUSE_COPYPRIVATE)
 229           && gfc_match_omp_variable_list ("copyprivate (",
 230                                           &c->lists[OMP_LIST_COPYPRIVATE],
 231                                           true)
 232              == MATCH_YES)
 233         continue;
 234       if ((mask & OMP_CLAUSE_SHARED)
 235           && gfc_match_omp_variable_list ("shared (",
 236                                           &c->lists[OMP_LIST_SHARED], true)
 237              == MATCH_YES)
 238         continue;
 239       if ((mask & OMP_CLAUSE_COPYIN)
 240           && gfc_match_omp_variable_list ("copyin (",
 241                                           &c->lists[OMP_LIST_COPYIN], true)
 242              == MATCH_YES)
 243         continue;
 244       old_loc = gfc_current_locus;
 245       if ((mask & OMP_CLAUSE_REDUCTION)
 246           && gfc_match ("reduction ( ") == MATCH_YES)
 247         {
 248           int reduction = OMP_LIST_NUM;
 249           char buffer[GFC_MAX_SYMBOL_LEN + 1];
 250           if (gfc_match_char ('+') == MATCH_YES)
 251             reduction = OMP_LIST_PLUS;
 252           else if (gfc_match_char ('*') == MATCH_YES)
 253             reduction = OMP_LIST_MULT;
 254           else if (gfc_match_char ('-') == MATCH_YES)
 255             reduction = OMP_LIST_SUB;
 256           else if (gfc_match (".and.") == MATCH_YES)
 257             reduction = OMP_LIST_AND;
 258           else if (gfc_match (".or.") == MATCH_YES)
 259             reduction = OMP_LIST_OR;
 260           else if (gfc_match (".eqv.") == MATCH_YES)
 261             reduction = OMP_LIST_EQV;
 262           else if (gfc_match (".neqv.") == MATCH_YES)
 263             reduction = OMP_LIST_NEQV;
 264           else if (gfc_match_name (buffer) == MATCH_YES)
 265             {
 266               gfc_symbol *sym;
 267               const char *n = buffer;
 268
 269               gfc_find_symbol (buffer, NULL, 1, &sym);
 270               if (sym != NULL)
 271                 {
 272                   if (sym->attr.intrinsic)
 273                     n = sym->name;
 274                   else if ((sym->attr.flavor != FL_UNKNOWN
 275                             && sym->attr.flavor != FL_PROCEDURE)
 276                            || sym->attr.external
 277                            || sym->attr.generic
 278                            || sym->attr.entry
 279                            || sym->attr.result
 280                            || sym->attr.dummy
 281                            || sym->attr.subroutine
 282                            || sym->attr.pointer
 283                            || sym->attr.target
 284                            || sym->attr.cray_pointer
 285                            || sym->attr.cray_pointee
 286                            || (sym->attr.proc != PROC_UNKNOWN
 287                                && sym->attr.proc != PROC_INTRINSIC)
 288                            || sym->attr.if_source != IFSRC_UNKNOWN
 289                            || sym == sym->ns->proc_name)
 290                     {
 291                       gfc_error_now ("%s is not INTRINSIC procedure name "
 292                                      "at %C", buffer);
 293                       sym = NULL;
 294                     }
 295                   else
 296                     n = sym->name;
 297                 }
 298               if (strcmp (n, "max") == 0)
 299                 reduction = OMP_LIST_MAX;
 300               else if (strcmp (n, "min") == 0)
 301                 reduction = OMP_LIST_MIN;
 302               else if (strcmp (n, "iand") == 0)
 303                 reduction = OMP_LIST_IAND;
 304               else if (strcmp (n, "ior") == 0)
 305                 reduction = OMP_LIST_IOR;
 306               else if (strcmp (n, "ieor") == 0)
 307                 reduction = OMP_LIST_IEOR;
 308               if (reduction != OMP_LIST_NUM
 309                   && sym != NULL
 310                   && ! sym->attr.intrinsic
 311                   && ! sym->attr.use_assoc
 312                   && ((sym->attr.flavor == FL_UNKNOWN
 313                        && gfc_add_flavor (&sym->attr, FL_PROCEDURE,
 314                                           sym->name, NULL) == FAILURE)
 315                       || gfc_add_intrinsic (&sym->attr, NULL) == FAILURE))
 316                 {
 317                   gfc_free_omp_clauses (c);
 318                   return MATCH_ERROR;
 319                 }
 320             }
 321           if (reduction != OMP_LIST_NUM
 322               && gfc_match_omp_variable_list (" :", &c->lists[reduction],
 323                                               false)
 324                  == MATCH_YES)
 325             continue;
 326           else
 327             gfc_current_locus = old_loc;
 328         }
 329       if ((mask & OMP_CLAUSE_DEFAULT)
 330           && c->default_sharing == OMP_DEFAULT_UNKNOWN)
 331         {
 332           if (gfc_match ("default ( shared )") == MATCH_YES)
 333             c->default_sharing = OMP_DEFAULT_SHARED;
 334           else if (gfc_match ("default ( private )") == MATCH_YES)
 335             c->default_sharing = OMP_DEFAULT_PRIVATE;
 336           else if (gfc_match ("default ( none )") == MATCH_YES)
 337             c->default_sharing = OMP_DEFAULT_NONE;
 338           if (c->default_sharing != OMP_DEFAULT_UNKNOWN)
 339             continue;
 340         }
 341       old_loc = gfc_current_locus;
 342       if ((mask & OMP_CLAUSE_SCHEDULE)
 343           && c->sched_kind == OMP_SCHED_NONE
 344           && gfc_match ("schedule ( ") == MATCH_YES)
 345         {
 346           if (gfc_match ("static") == MATCH_YES)
 347             c->sched_kind = OMP_SCHED_STATIC;
 348           else if (gfc_match ("dynamic") == MATCH_YES)
 349             c->sched_kind = OMP_SCHED_DYNAMIC;
 350           else if (gfc_match ("guided") == MATCH_YES)
 351             c->sched_kind = OMP_SCHED_GUIDED;
 352           else if (gfc_match ("runtime") == MATCH_YES)
 353             c->sched_kind = OMP_SCHED_RUNTIME;
 354           if (c->sched_kind != OMP_SCHED_NONE)
 355             {
 356               match m = MATCH_NO;
 357               if (c->sched_kind != OMP_SCHED_RUNTIME)
 358                 m = gfc_match (" , %e )", &c->chunk_size);
 359               if (m != MATCH_YES)
 360                 m = gfc_match_char (')');
 361               if (m != MATCH_YES)
 362                 c->sched_kind = OMP_SCHED_NONE;
 363             }
 364           if (c->sched_kind != OMP_SCHED_NONE)
 365             continue;
 366           else
 367             gfc_current_locus = old_loc;
 368         }
 369       if ((mask & OMP_CLAUSE_ORDERED) && !c->ordered
 370           && gfc_match ("ordered") == MATCH_YES)
 371         {
 372           c->ordered = needs_space = true;
 373           continue;
 374         }
 375
 376       break;
 377     }
 378
 379   if (gfc_match_omp_eos () != MATCH_YES)
 380     {
 381       gfc_free_omp_clauses (c);
 382       return MATCH_ERROR;
 383     }
 384
 385   *cp = c;
 386   return MATCH_YES;
 387 }
 388
 389 #define OMP_PARALLEL_CLAUSES \
 390   (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED     \
 391    | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IF           \
 392    | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT)
 393 #define OMP_DO_CLAUSES \
 394   (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE                         \
 395    | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION                      \
 396    | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED)
 397 #define OMP_SECTIONS_CLAUSES \
 398   (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE                         \
 399    | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
 400
 401 match
 402 gfc_match_omp_parallel (void)
 403 {
 404   gfc_omp_clauses *c;
 405   if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES) != MATCH_YES)
 406     return MATCH_ERROR;
 407   new_st.op = EXEC_OMP_PARALLEL;
 408   new_st.ext.omp_clauses = c;
 409   return MATCH_YES;
 410 }
 411
 412
 413 match
 414 gfc_match_omp_critical (void)
 415 {
 416   char n[GFC_MAX_SYMBOL_LEN+1];
 417
 418   if (gfc_match (" ( %n )", n) != MATCH_YES)
 419     n[0] = '\0';
 420   if (gfc_match_omp_eos () != MATCH_YES)
 421     return MATCH_ERROR;
 422   new_st.op = EXEC_OMP_CRITICAL;
 423   new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
 424   return MATCH_YES;
 425 }
 426
 427
 428 match
 429 gfc_match_omp_do (void)
 430 {
 431   gfc_omp_clauses *c;
 432   if (gfc_match_omp_clauses (&c, OMP_DO_CLAUSES) != MATCH_YES)
 433     return MATCH_ERROR;
 434   new_st.op = EXEC_OMP_DO;
 435   new_st.ext.omp_clauses = c;
 436   return MATCH_YES;
 437 }
 438
 439
 440 match
 441 gfc_match_omp_flush (void)
 442 {
 443   gfc_namelist *list = NULL;
 444   gfc_match_omp_variable_list (" (", &list, true);
 445   if (gfc_match_omp_eos () != MATCH_YES)
 446     {
 447       gfc_free_namelist (list);
 448       return MATCH_ERROR;
 449     }
 450   new_st.op = EXEC_OMP_FLUSH;
 451   new_st.ext.omp_namelist = list;
 452   return MATCH_YES;
 453 }
 454
 455
 456 match
 457 gfc_match_omp_threadprivate (void)
 458 {
 459   locus old_loc;
 460   char n[GFC_MAX_SYMBOL_LEN+1];
 461   gfc_symbol *sym;
 462   match m;
 463   gfc_symtree *st;
 464
 465   old_loc = gfc_current_locus;
 466
 467   m = gfc_match (" (");
 468   if (m != MATCH_YES)
 469     return m;
 470
 471   for (;;)
 472     {
 473       m = gfc_match_symbol (&sym, 0);
 474       switch (m)
 475         {
 476         case MATCH_YES:
 477           if (sym->attr.in_common)
 478             gfc_error_now ("Threadprivate variable at %C is an element of "
 479                            "a COMMON block");
 480           else if (gfc_add_threadprivate (&sym->attr, sym->name,
 481                    &sym->declared_at) == FAILURE)
 482             goto cleanup;
 483           goto next_item;
 484         case MATCH_NO:
 485           break;
 486         case MATCH_ERROR:
 487           goto cleanup;
 488         }
 489
 490       m = gfc_match (" / %n /", n);
 491       if (m == MATCH_ERROR)
 492         goto cleanup;
 493       if (m == MATCH_NO || n[0] == '\0')
 494         goto syntax;
 495
 496       st = gfc_find_symtree (gfc_current_ns->common_root, n);
 497       if (st == NULL)
 498         {
 499           gfc_error ("COMMON block /%s/ not found at %C", n);
 500           goto cleanup;
 501         }
 502       st->n.common->threadprivate = 1;
 503       for (sym = st->n.common->head; sym; sym = sym->common_next)
 504         if (gfc_add_threadprivate (&sym->attr, sym->name,
 505                                    &sym->declared_at) == FAILURE)
 506           goto cleanup;
 507
 508     next_item:
 509       if (gfc_match_char (')') == MATCH_YES)
 510         break;
 511       if (gfc_match_char (',') != MATCH_YES)
 512         goto syntax;
 513     }
 514
 515   return MATCH_YES;
 516
 517 syntax:
 518   gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
 519
 520 cleanup:
 521   gfc_current_locus = old_loc;
 522   return MATCH_ERROR;
 523 }
 524
 525
 526 match
 527 gfc_match_omp_parallel_do (void)
 528 {
 529   gfc_omp_clauses *c;
 530   if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
 531       != MATCH_YES)
 532     return MATCH_ERROR;
 533   new_st.op = EXEC_OMP_PARALLEL_DO;
 534   new_st.ext.omp_clauses = c;
 535   return MATCH_YES;
 536 }
 537
 538
 539 match
 540 gfc_match_omp_parallel_sections (void)
 541 {
 542   gfc_omp_clauses *c;
 543   if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES)
 544       != MATCH_YES)
 545     return MATCH_ERROR;
 546   new_st.op = EXEC_OMP_PARALLEL_SECTIONS;
 547   new_st.ext.omp_clauses = c;
 548   return MATCH_YES;
 549 }
 550
 551
 552 match
 553 gfc_match_omp_parallel_workshare (void)
 554 {
 555   gfc_omp_clauses *c;
 556   if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES) != MATCH_YES)
 557     return MATCH_ERROR;
 558   new_st.op = EXEC_OMP_PARALLEL_WORKSHARE;
 559   new_st.ext.omp_clauses = c;
 560   return MATCH_YES;
 561 }
 562
 563
 564 match
 565 gfc_match_omp_sections (void)
 566 {
 567   gfc_omp_clauses *c;
 568   if (gfc_match_omp_clauses (&c, OMP_SECTIONS_CLAUSES) != MATCH_YES)
 569     return MATCH_ERROR;
 570   new_st.op = EXEC_OMP_SECTIONS;
 571   new_st.ext.omp_clauses = c;
 572   return MATCH_YES;
 573 }
 574
 575
 576 match
 577 gfc_match_omp_single (void)
 578 {
 579   gfc_omp_clauses *c;
 580   if (gfc_match_omp_clauses (&c, OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE)
 581       != MATCH_YES)
 582     return MATCH_ERROR;
 583   new_st.op = EXEC_OMP_SINGLE;
 584   new_st.ext.omp_clauses = c;
 585   return MATCH_YES;
 586 }
 587
 588
 589 match
 590 gfc_match_omp_workshare (void)
 591 {
 592   if (gfc_match_omp_eos () != MATCH_YES)
 593     return MATCH_ERROR;
 594   new_st.op = EXEC_OMP_WORKSHARE;
 595   new_st.ext.omp_clauses = gfc_get_omp_clauses ();
 596   return MATCH_YES;
 597 }
 598
 599
 600 match
 601 gfc_match_omp_master (void)
 602 {
 603   if (gfc_match_omp_eos () != MATCH_YES)
 604     return MATCH_ERROR;
 605   new_st.op = EXEC_OMP_MASTER;
 606   new_st.ext.omp_clauses = NULL;
 607   return MATCH_YES;
 608 }
 609
 610
 611 match
 612 gfc_match_omp_ordered (void)
 613 {
 614   if (gfc_match_omp_eos () != MATCH_YES)
 615     return MATCH_ERROR;
 616   new_st.op = EXEC_OMP_ORDERED;
 617   new_st.ext.omp_clauses = NULL;
 618   return MATCH_YES;
 619 }
 620
 621
 622 match
 623 gfc_match_omp_atomic (void)
 624 {
 625   if (gfc_match_omp_eos () != MATCH_YES)
 626     return MATCH_ERROR;
 627   new_st.op = EXEC_OMP_ATOMIC;
 628   new_st.ext.omp_clauses = NULL;
 629   return MATCH_YES;
 630 }
 631
 632
 633 match
 634 gfc_match_omp_barrier (void)
 635 {
 636   if (gfc_match_omp_eos () != MATCH_YES)
 637     return MATCH_ERROR;
 638   new_st.op = EXEC_OMP_BARRIER;
 639   new_st.ext.omp_clauses = NULL;
 640   return MATCH_YES;
 641 }
 642
 643
 644 match
 645 gfc_match_omp_end_nowait (void)
 646 {
 647   bool nowait = false;
 648   if (gfc_match ("% nowait") == MATCH_YES)
 649     nowait = true;
 650   if (gfc_match_omp_eos () != MATCH_YES)
 651     return MATCH_ERROR;
 652   new_st.op = EXEC_OMP_END_NOWAIT;
 653   new_st.ext.omp_bool = nowait;
 654   return MATCH_YES;
 655 }
 656
 657
 658 match
 659 gfc_match_omp_end_single (void)
 660 {
 661   gfc_omp_clauses *c;
 662   if (gfc_match ("% nowait") == MATCH_YES)
 663     {
 664       new_st.op = EXEC_OMP_END_NOWAIT;
 665       new_st.ext.omp_bool = true;
 666       return MATCH_YES;
 667     }
 668   if (gfc_match_omp_clauses (&c, OMP_CLAUSE_COPYPRIVATE) != MATCH_YES)
 669     return MATCH_ERROR;
 670   new_st.op = EXEC_OMP_END_SINGLE;
 671   new_st.ext.omp_clauses = c;
 672   return MATCH_YES;
 673 }
 674
 675
 676 /* OpenMP directive resolving routines.  */
 677
 678 static void
 679 resolve_omp_clauses (gfc_code *code)
 680 {
 681   gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
 682   gfc_namelist *n;
 683   int list;
 684   static const char *clause_names[]
 685     = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
 686         "COPYIN", "REDUCTION" };
 687
 688   if (omp_clauses == NULL)
 689     return;
 690
 691   if (omp_clauses->if_expr)
 692     {
 693       gfc_expr *expr = omp_clauses->if_expr;
 694       if (gfc_resolve_expr (expr) == FAILURE
 695           || expr->ts.type != BT_LOGICAL || expr->rank != 0)
 696         gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
 697                    &expr->where);
 698     }
 699   if (omp_clauses->num_threads)
 700     {
 701       gfc_expr *expr = omp_clauses->num_threads;
 702       if (gfc_resolve_expr (expr) == FAILURE
 703           || expr->ts.type != BT_INTEGER || expr->rank != 0)
 704         gfc_error ("NUM_THREADS clause at %L requires a scalar "
 705                    "INTEGER expression", &expr->where);
 706     }
 707   if (omp_clauses->chunk_size)
 708     {
 709       gfc_expr *expr = omp_clauses->chunk_size;
 710       if (gfc_resolve_expr (expr) == FAILURE
 711           || expr->ts.type != BT_INTEGER || expr->rank != 0)
 712         gfc_error ("SCHEDULE clause's chunk_size at %L requires "
 713                    "a scalar INTEGER expression", &expr->where);
 714     }
 715
 716   /* Check that no symbol appears on multiple clauses, except that
 717      a symbol can appear on both firstprivate and lastprivate.  */
 718   for (list = 0; list < OMP_LIST_NUM; list++)
 719     for (n = omp_clauses->lists[list]; n; n = n->next)
 720       n->sym->mark = 0;
 721
 722   for (list = 0; list < OMP_LIST_NUM; list++)
 723     if (list != OMP_LIST_FIRSTPRIVATE && list != OMP_LIST_LASTPRIVATE)
 724       for (n = omp_clauses->lists[list]; n; n = n->next)
 725         if (n->sym->mark)
 726           gfc_error ("Symbol '%s' present on multiple clauses at %L",
 727                      n->sym->name, &code->loc);
 728         else
 729           n->sym->mark = 1;
 730
 731   gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
 732   for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++)
 733     for (n = omp_clauses->lists[list]; n; n = n->next)
 734       if (n->sym->mark)
 735         {
 736           gfc_error ("Symbol '%s' present on multiple clauses at %L",
 737                      n->sym->name, &code->loc);
 738           n->sym->mark = 0;
 739         }
 740
 741   for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
 742     if (n->sym->mark)
 743       gfc_error ("Symbol '%s' present on multiple clauses at %L",
 744                  n->sym->name, &code->loc);
 745     else
 746       n->sym->mark = 1;
 747
 748   for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
 749     n->sym->mark = 0;
 750
 751   for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
 752     if (n->sym->mark)
 753       gfc_error ("Symbol '%s' present on multiple clauses at %L",
 754                  n->sym->name, &code->loc);
 755     else
 756       n->sym->mark = 1;
 757
 758   for (list = 0; list < OMP_LIST_NUM; list++)
 759     if ((n = omp_clauses->lists[list]) != NULL)
 760       {
 761         const char *name;
 762
 763         if (list < OMP_LIST_REDUCTION_FIRST)
 764           name = clause_names[list];
 765         else if (list <= OMP_LIST_REDUCTION_LAST)
 766           name = clause_names[OMP_LIST_REDUCTION_FIRST];
 767         else
 768           gcc_unreachable ();
 769
 770         switch (list)
 771           {
 772           case OMP_LIST_COPYIN:
 773             for (; n != NULL; n = n->next)
 774               {
 775                 if (!n->sym->attr.threadprivate)
 776                   gfc_error ("Non-THREADPRIVATE object '%s' in COPYIN clause"
 777                              " at %L", n->sym->name, &code->loc);
 778                 if (n->sym->attr.allocatable)
 779                   gfc_error ("COPYIN clause object '%s' is ALLOCATABLE at %L",
 780                              n->sym->name, &code->loc);
 781                 if (n->sym->ts.type == BT_DERIVED && n->sym->ts.derived->attr.alloc_comp)
 782                   gfc_error ("COPYIN clause object '%s' at %L has ALLOCATABLE components",
 783                              n->sym->name, &code->loc);
 784               }
 785             break;
 786           case OMP_LIST_COPYPRIVATE:
 787             for (; n != NULL; n = n->next)
 788               {
 789                 if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
 790                   gfc_error ("Assumed size array '%s' in COPYPRIVATE clause "
 791                              "at %L", n->sym->name, &code->loc);
 792                 if (n->sym->attr.allocatable)
 793                   gfc_error ("COPYPRIVATE clause object '%s' is ALLOCATABLE "
 794                              "at %L", n->sym->name, &code->loc);
 795                 if (n->sym->ts.type == BT_DERIVED && n->sym->ts.derived->attr.alloc_comp)
 796                   gfc_error ("COPYPRIVATE clause object '%s' at %L has ALLOCATABLE components",
 797                              n->sym->name, &code->loc);
 798               }
 799             break;
 800           case OMP_LIST_SHARED:
 801             for (; n != NULL; n = n->next)
 802               {
 803                 if (n->sym->attr.threadprivate)
 804                   gfc_error ("THREADPRIVATE object '%s' in SHARED clause at "
 805                              "%L", n->sym->name, &code->loc);
 806                 if (n->sym->attr.cray_pointee)
 807                   gfc_error ("Cray pointee '%s' in SHARED clause at %L",
 808                             n->sym->name, &code->loc);
 809               }
 810             break;
 811           default:
 812             for (; n != NULL; n = n->next)
 813               {
 814                 if (n->sym->attr.threadprivate)
 815                   gfc_error ("THREADPRIVATE object '%s' in %s clause at %L",
 816                              n->sym->name, name, &code->loc);
 817                 if (n->sym->attr.cray_pointee)
 818                   gfc_error ("Cray pointee '%s' in %s clause at %L",
 819                             n->sym->name, name, &code->loc);
 820                 if (list != OMP_LIST_PRIVATE)
 821                   {
 822                     if (n->sym->attr.pointer)
 823                       gfc_error ("POINTER object '%s' in %s clause at %L",
 824                                  n->sym->name, name, &code->loc);
 825                     if (n->sym->attr.allocatable)
 826                       gfc_error ("%s clause object '%s' is ALLOCATABLE at %L",
 827                                  name, n->sym->name, &code->loc);
 828                     /* Variables in REDUCTION-clauses must be of intrinsic type (flagged below).  */
 829                     if ((list < OMP_LIST_REDUCTION_FIRST || list > OMP_LIST_REDUCTION_LAST) &&
 830                         n->sym->ts.type == BT_DERIVED && n->sym->ts.derived->attr.alloc_comp)
 831                       gfc_error ("%s clause object '%s' has ALLOCATABLE components at %L",
 832                                  name, n->sym->name, &code->loc);
 833                     if (n->sym->attr.cray_pointer)
 834                       gfc_error ("Cray pointer '%s' in %s clause at %L",
 835                                  n->sym->name, name, &code->loc);
 836                   }
 837                 if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
 838                   gfc_error ("Assumed size array '%s' in %s clause at %L",
 839                              n->sym->name, name, &code->loc);
 840                 if (n->sym->attr.in_namelist
 841                     && (list < OMP_LIST_REDUCTION_FIRST
 842                         || list > OMP_LIST_REDUCTION_LAST))
 843                   gfc_error ("Variable '%s' in %s clause is used in "
 844                              "NAMELIST statement at %L",
 845                              n->sym->name, name, &code->loc);
 846                 switch (list)
 847                   {
 848                   case OMP_LIST_PLUS:
 849                   case OMP_LIST_MULT:
 850                   case OMP_LIST_SUB:
 851                     if (!gfc_numeric_ts (&n->sym->ts))
 852                       gfc_error ("%c REDUCTION variable '%s' at %L must be of numeric type, got %s",
 853                                  list == OMP_LIST_PLUS ? '+'
 854                                  : list == OMP_LIST_MULT ? '*' : '-',
 855                                  n->sym->name, &code->loc,
 856                                  gfc_typename (&n->sym->ts));
 857                     break;
 858                   case OMP_LIST_AND:
 859                   case OMP_LIST_OR:
 860                   case OMP_LIST_EQV:
 861                   case OMP_LIST_NEQV:
 862                     if (n->sym->ts.type != BT_LOGICAL)
 863                       gfc_error ("%s REDUCTION variable '%s' must be LOGICAL "
 864                                  "at %L",
 865                                  list == OMP_LIST_AND ? ".AND."
 866                                  : list == OMP_LIST_OR ? ".OR."
 867                                  : list == OMP_LIST_EQV ? ".EQV." : ".NEQV.",
 868                                  n->sym->name, &code->loc);
 869                     break;
 870                   case OMP_LIST_MAX:
 871                   case OMP_LIST_MIN:
 872                     if (n->sym->ts.type != BT_INTEGER
 873                         && n->sym->ts.type != BT_REAL)
 874                       gfc_error ("%s REDUCTION variable '%s' must be "
 875                                  "INTEGER or REAL at %L",
 876                                  list == OMP_LIST_MAX ? "MAX" : "MIN",
 877                                  n->sym->name, &code->loc);
 878                     break;
 879                   case OMP_LIST_IAND:
 880                   case OMP_LIST_IOR:
 881                   case OMP_LIST_IEOR:
 882                     if (n->sym->ts.type != BT_INTEGER)
 883                       gfc_error ("%s REDUCTION variable '%s' must be INTEGER "
 884                                  "at %L",
 885                                  list == OMP_LIST_IAND ? "IAND"
 886                                  : list == OMP_LIST_MULT ? "IOR" : "IEOR",
 887                                  n->sym->name, &code->loc);
 888                     break;
 889                   /* Workaround for PR middle-end/26316, nothing really needs
 890                      to be done here for OMP_LIST_PRIVATE.  */
 891                   case OMP_LIST_PRIVATE:
 892                     gcc_assert (code->op != EXEC_NOP);
 893                   default:
 894                     break;
 895                   }
 896               }
 897             break;
 898           }
 899       }
 900 }
 901
 902
 903 /* Return true if SYM is ever referenced in EXPR except in the SE node.  */
 904
 905 static bool
 906 expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
 907 {
 908   gfc_actual_arglist *arg;
 909   if (e == NULL || e == se)
 910     return false;
 911   switch (e->expr_type)
 912     {
 913     case EXPR_CONSTANT:
 914     case EXPR_NULL:
 915     case EXPR_VARIABLE:
 916     case EXPR_STRUCTURE:
 917     case EXPR_ARRAY:
 918       if (e->symtree != NULL
 919           && e->symtree->n.sym == s)
 920         return true;
 921       return false;
 922     case EXPR_SUBSTRING:
 923       if (e->ref != NULL
 924           && (expr_references_sym (e->ref->u.ss.start, s, se)
 925               || expr_references_sym (e->ref->u.ss.end, s, se)))
 926         return true;
 927       return false;
 928     case EXPR_OP:
 929       if (expr_references_sym (e->value.op.op2, s, se))
 930         return true;
 931       return expr_references_sym (e->value.op.op1, s, se);
 932     case EXPR_FUNCTION:
 933       for (arg = e->value.function.actual; arg; arg = arg->next)
 934         if (expr_references_sym (arg->expr, s, se))
 935           return true;
 936       return false;
 937     default:
 938       gcc_unreachable ();
 939     }
 940 }
 941
 942
 943 /* If EXPR is a conversion function that widens the type
 944    if WIDENING is true or narrows the type if WIDENING is false,
 945    return the inner expression, otherwise return NULL.  */
 946
 947 static gfc_expr *
 948 is_conversion (gfc_expr *expr, bool widening)
 949 {
 950   gfc_typespec *ts1, *ts2;
 951
 952   if (expr->expr_type != EXPR_FUNCTION
 953       || expr->value.function.isym == NULL
 954       || expr->value.function.esym != NULL
 955       || expr->value.function.isym->id != GFC_ISYM_CONVERSION)
 956     return NULL;
 957
 958   if (widening)
 959     {
 960       ts1 = &expr->ts;
 961       ts2 = &expr->value.function.actual->expr->ts;
 962     }
 963   else
 964     {
 965       ts1 = &expr->value.function.actual->expr->ts;
 966       ts2 = &expr->ts;
 967     }
 968
 969   if (ts1->type > ts2->type
 970       || (ts1->type == ts2->type && ts1->kind > ts2->kind))
 971     return expr->value.function.actual->expr;
 972
 973   return NULL;
 974 }
 975
 976
 977 static void
 978 resolve_omp_atomic (gfc_code *code)
 979 {
 980   gfc_symbol *var;
 981   gfc_expr *expr2;
 982
 983   code = code->block->next;
 984   gcc_assert (code->op == EXEC_ASSIGN);
 985   gcc_assert (code->next == NULL);
 986
 987   if (code->expr->expr_type != EXPR_VARIABLE
 988       || code->expr->symtree == NULL
 989       || code->expr->rank != 0
 990       || (code->expr->ts.type != BT_INTEGER
 991           && code->expr->ts.type != BT_REAL
 992           && code->expr->ts.type != BT_COMPLEX
 993           && code->expr->ts.type != BT_LOGICAL))
 994     {
 995       gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
 996                  "intrinsic type at %L", &code->loc);
 997       return;
 998     }
 999
1000   var = code->expr->symtree->n.sym;
1001   expr2 = is_conversion (code->expr2, false);
1002   if (expr2 == NULL)
1003     expr2 = code->expr2;
1004
1005   if (expr2->expr_type == EXPR_OP)
1006     {
1007       gfc_expr *v = NULL, *e, *c;
1008       gfc_intrinsic_op op = expr2->value.op.operator;
1009       gfc_intrinsic_op alt_op = INTRINSIC_NONE;
1010
1011       switch (op)
1012         {
1013         case INTRINSIC_PLUS:
1014           alt_op = INTRINSIC_MINUS;
1015           break;
1016         case INTRINSIC_TIMES:
1017           alt_op = INTRINSIC_DIVIDE;
1018           break;
1019         case INTRINSIC_MINUS:
1020           alt_op = INTRINSIC_PLUS;
1021           break;
1022         case INTRINSIC_DIVIDE:
1023           alt_op = INTRINSIC_TIMES;
1024           break;
1025         case INTRINSIC_AND:
1026         case INTRINSIC_OR:
1027           break;
1028         case INTRINSIC_EQV:
1029           alt_op = INTRINSIC_NEQV;
1030           break;
1031         case INTRINSIC_NEQV:
1032           alt_op = INTRINSIC_EQV;
1033           break;
1034         default:
1035           gfc_error ("!$OMP ATOMIC assignment operator must be "
1036                      "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
1037                      &expr2->where);
1038           return;
1039         }
1040
1041       /* Check for var = var op expr resp. var = expr op var where
1042          expr doesn't reference var and var op expr is mathematically
1043          equivalent to var op (expr) resp. expr op var equivalent to
1044          (expr) op var.  We rely here on the fact that the matcher
1045          for x op1 y op2 z where op1 and op2 have equal precedence
1046          returns (x op1 y) op2 z.  */
1047       e = expr2->value.op.op2;
1048       if (e->expr_type == EXPR_VARIABLE
1049           && e->symtree != NULL
1050           && e->symtree->n.sym == var)
1051         v = e;
1052       else if ((c = is_conversion (e, true)) != NULL
1053                && c->expr_type == EXPR_VARIABLE
1054                && c->symtree != NULL
1055                && c->symtree->n.sym == var)
1056         v = c;
1057       else
1058         {
1059           gfc_expr **p = NULL, **q;
1060           for (q = &expr2->value.op.op1; (e = *q) != NULL; )
1061             if (e->expr_type == EXPR_VARIABLE
1062                 && e->symtree != NULL
1063                 && e->symtree->n.sym == var)
1064               {
1065                 v = e;
1066                 break;
1067               }
1068             else if ((c = is_conversion (e, true)) != NULL)
1069               q = &e->value.function.actual->expr;
1070             else if (e->expr_type != EXPR_OP
1071                      || (e->value.op.operator != op
1072                          && e->value.op.operator != alt_op)
1073                      || e->rank != 0)
1074               break;
1075             else
1076               {
1077                 p = q;
1078                 q = &e->value.op.op1;
1079               }
1080
1081           if (v == NULL)
1082             {
1083               gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
1084                          "or var = expr op var at %L", &expr2->where);
1085               return;
1086             }
1087
1088           if (p != NULL)
1089             {
1090               e = *p;
1091               switch (e->value.op.operator)
1092                 {
1093                 case INTRINSIC_MINUS:
1094                 case INTRINSIC_DIVIDE:
1095                 case INTRINSIC_EQV:
1096                 case INTRINSIC_NEQV:
1097                   gfc_error ("!$OMP ATOMIC var = var op expr not "
1098                              "mathematically equivalent to var = var op "
1099                              "(expr) at %L", &expr2->where);
1100                   break;
1101                 default:
1102                   break;
1103                 }
1104
1105               /* Canonicalize into var = var op (expr).  */
1106               *p = e->value.op.op2;
1107               e->value.op.op2 = expr2;
1108               e->ts = expr2->ts;
1109               if (code->expr2 == expr2)
1110                 code->expr2 = expr2 = e;
1111               else
1112                 code->expr2->value.function.actual->expr = expr2 = e;
1113
1114               if (!gfc_compare_types (&expr2->value.op.op1->ts, &expr2->ts))
1115                 {
1116                   for (p = &expr2->value.op.op1; *p != v;
1117                        p = &(*p)->value.function.actual->expr)
1118                     ;
1119                   *p = NULL;
1120                   gfc_free_expr (expr2->value.op.op1);
1121                   expr2->value.op.op1 = v;
1122                   gfc_convert_type (v, &expr2->ts, 2);
1123                 }
1124             }
1125         }
1126
1127       if (e->rank != 0 || expr_references_sym (code->expr2, var, v))
1128         {
1129           gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
1130                      "must be scalar and cannot reference var at %L",
1131                      &expr2->where);
1132           return;
1133         }
1134     }
1135   else if (expr2->expr_type == EXPR_FUNCTION
1136            && expr2->value.function.isym != NULL
1137            && expr2->value.function.esym == NULL
1138            && expr2->value.function.actual != NULL
1139            && expr2->value.function.actual->next != NULL)
1140     {
1141       gfc_actual_arglist *arg, *var_arg;
1142
1143       switch (expr2->value.function.isym->id)
1144         {
1145         case GFC_ISYM_MIN:
1146         case GFC_ISYM_MAX:
1147           break;
1148         case GFC_ISYM_IAND:
1149         case GFC_ISYM_IOR:
1150         case GFC_ISYM_IEOR:
1151           if (expr2->value.function.actual->next->next != NULL)
1152             {
1153               gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
1154                          "or IEOR must have two arguments at %L",
1155                          &expr2->where);
1156               return;
1157             }
1158           break;
1159         default:
1160           gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
1161                      "MIN, MAX, IAND, IOR or IEOR at %L",
1162                      &expr2->where);
1163           return;
1164         }
1165
1166       var_arg = NULL;
1167       for (arg = expr2->value.function.actual; arg; arg = arg->next)
1168         {
1169           if ((arg == expr2->value.function.actual
1170                || (var_arg == NULL && arg->next == NULL))
1171               && arg->expr->expr_type == EXPR_VARIABLE
1172               && arg->expr->symtree != NULL
1173               && arg->expr->symtree->n.sym == var)
1174             var_arg = arg;
1175           else if (expr_references_sym (arg->expr, var, NULL))
1176             gfc_error ("!$OMP ATOMIC intrinsic arguments except one must not "
1177                        "reference '%s' at %L", var->name, &arg->expr->where);
1178           if (arg->expr->rank != 0)
1179             gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
1180                        "at %L", &arg->expr->where);
1181         }
1182
1183       if (var_arg == NULL)
1184         {
1185           gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
1186                      "be '%s' at %L", var->name, &expr2->where);
1187           return;
1188         }
1189
1190       if (var_arg != expr2->value.function.actual)
1191         {
1192           /* Canonicalize, so that var comes first.  */
1193           gcc_assert (var_arg->next == NULL);
1194           for (arg = expr2->value.function.actual;
1195                arg->next != var_arg; arg = arg->next)
1196             ;
1197           var_arg->next = expr2->value.function.actual;
1198           expr2->value.function.actual = var_arg;
1199           arg->next = NULL;
1200         }
1201     }
1202   else
1203     gfc_error ("!$OMP ATOMIC assignment must have an operator or intrinsic "
1204                "on right hand side at %L", &expr2->where);
1205 }
1206
1207
1208 struct omp_context
1209 {
1210   gfc_code *code;
1211   struct pointer_set_t *sharing_clauses;
1212   struct pointer_set_t *private_iterators;
1213   struct omp_context *previous;
1214 } *omp_current_ctx;
1215 gfc_code *omp_current_do_code;
1216
1217
1218 void
1219 gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
1220 {
1221   if (code->block->next && code->block->next->op == EXEC_DO)
1222     omp_current_do_code = code->block->next;
1223   gfc_resolve_blocks (code->block, ns);
1224 }
1225
1226
1227 void
1228 gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
1229 {
1230   struct omp_context ctx;
1231   gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
1232   gfc_namelist *n;
1233   int list;
1234
1235   ctx.code = code;
1236   ctx.sharing_clauses = pointer_set_create ();
1237   ctx.private_iterators = pointer_set_create ();
1238   ctx.previous = omp_current_ctx;
1239   omp_current_ctx = &ctx;
1240
1241   for (list = 0; list < OMP_LIST_NUM; list++)
1242     for (n = omp_clauses->lists[list]; n; n = n->next)
1243       pointer_set_insert (ctx.sharing_clauses, n->sym);
1244
1245   if (code->op == EXEC_OMP_PARALLEL_DO)
1246     gfc_resolve_omp_do_blocks (code, ns);
1247   else
1248     gfc_resolve_blocks (code->block, ns);
1249
1250   omp_current_ctx = ctx.previous;
1251   pointer_set_destroy (ctx.sharing_clauses);
1252   pointer_set_destroy (ctx.private_iterators);
1253 }
1254
1255
1256 /* Note a DO iterator variable.  This is special in !$omp parallel
1257    construct, where they are predetermined private.  */
1258
1259 void
1260 gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym)
1261 {
1262   struct omp_context *ctx;
1263
1264   if (sym->attr.threadprivate)
1265     return;
1266
1267   /* !$omp do and !$omp parallel do iteration variable is predetermined
1268      private just in the !$omp do resp. !$omp parallel do construct,
1269      with no implications for the outer parallel constructs.  */
1270   if (code == omp_current_do_code)
1271     return;
1272
1273   for (ctx = omp_current_ctx; ctx; ctx = ctx->previous)
1274     {
1275       if (pointer_set_contains (ctx->sharing_clauses, sym))
1276         continue;
1277
1278       if (! pointer_set_insert (ctx->private_iterators, sym))
1279         {
1280           gfc_omp_clauses *omp_clauses = ctx->code->ext.omp_clauses;
1281           gfc_namelist *p;
1282
1283           p = gfc_get_namelist ();
1284           p->sym = sym;
1285           p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
1286           omp_clauses->lists[OMP_LIST_PRIVATE] = p;
1287         }
1288     }
1289 }
1290
1291
1292 static void
1293 resolve_omp_do (gfc_code *code)
1294 {
1295   gfc_code *do_code;
1296   int list;
1297   gfc_namelist *n;
1298   gfc_symbol *dovar;
1299
1300   if (code->ext.omp_clauses)
1301     resolve_omp_clauses (code);
1302
1303   do_code = code->block->next;
1304   if (do_code->op == EXEC_DO_WHILE)
1305     gfc_error ("!$OMP DO cannot be a DO WHILE or DO without loop control "
1306                "at %L", &do_code->loc);
1307   else
1308     {
1309       gcc_assert (do_code->op == EXEC_DO);
1310       if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
1311         gfc_error ("!$OMP DO iteration variable must be of type integer at %L",
1312                    &do_code->loc);
1313       dovar = do_code->ext.iterator->var->symtree->n.sym;
1314       if (dovar->attr.threadprivate)
1315         gfc_error ("!$OMP DO iteration variable must not be THREADPRIVATE "
1316                    "at %L", &do_code->loc);
1317       if (code->ext.omp_clauses)
1318         for (list = 0; list < OMP_LIST_NUM; list++)
1319           if (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE)
1320             for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
1321               if (dovar == n->sym)
1322                 {
1323                   gfc_error ("!$OMP DO iteration variable present on clause "
1324                              "other than PRIVATE or LASTPRIVATE at %L",
1325                              &do_code->loc);
1326                   break;
1327                 }
1328     }
1329 }
1330
1331
1332 /* Resolve OpenMP directive clauses and check various requirements
1333    of each directive.  */
1334
1335 void
1336 gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
1337 {
1338   switch (code->op)
1339     {
1340     case EXEC_OMP_DO:
1341     case EXEC_OMP_PARALLEL_DO:
1342       resolve_omp_do (code);
1343       break;
1344     case EXEC_OMP_WORKSHARE:
1345     case EXEC_OMP_PARALLEL_WORKSHARE:
1346     case EXEC_OMP_PARALLEL:
1347     case EXEC_OMP_PARALLEL_SECTIONS:
1348     case EXEC_OMP_SECTIONS:
1349     case EXEC_OMP_SINGLE:
1350       if (code->ext.omp_clauses)
1351         resolve_omp_clauses (code);
1352       break;
1353     case EXEC_OMP_ATOMIC:
1354       resolve_omp_atomic (code);
1355       break;
1356     default:
1357       break;
1358     }
1359 }