gcc/fortran/openmp.c

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