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