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                   /* Workaround for PR middle-end/26316, nothing really needs
 869                      to be done here for OMP_LIST_PRIVATE.  */
 870                   case OMP_LIST_PRIVATE:
 871                     gcc_assert (code->op != EXEC_NOP);
 872                   default:
 873                     break;
 874                   }
 875               }
 876             break;
 877           }
 878       }
 879 }
 880
 881 /* Return true if SYM is ever referenced in EXPR except in the SE node.  */
 882
 883 static bool
 884 expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
 885 {
 886   gfc_actual_arglist *arg;
 887   if (e == NULL || e == se)
 888     return false;
 889   switch (e->expr_type)
 890     {
 891     case EXPR_CONSTANT:
 892     case EXPR_NULL:
 893     case EXPR_VARIABLE:
 894     case EXPR_STRUCTURE:
 895     case EXPR_ARRAY:
 896       if (e->symtree != NULL
 897           && e->symtree->n.sym == s)
 898         return true;
 899       return false;
 900     case EXPR_SUBSTRING:
 901       if (e->ref != NULL
 902           && (expr_references_sym (e->ref->u.ss.start, s, se)
 903               || expr_references_sym (e->ref->u.ss.end, s, se)))
 904         return true;
 905       return false;
 906     case EXPR_OP:
 907       if (expr_references_sym (e->value.op.op2, s, se))
 908         return true;
 909       return expr_references_sym (e->value.op.op1, s, se);
 910     case EXPR_FUNCTION:
 911       for (arg = e->value.function.actual; arg; arg = arg->next)
 912         if (expr_references_sym (arg->expr, s, se))
 913           return true;
 914       return false;
 915     default:
 916       gcc_unreachable ();
 917     }
 918 }
 919
 920 /* If EXPR is a conversion function that widens the type
 921    if WIDENING is true or narrows the type if WIDENING is false,
 922    return the inner expression, otherwise return NULL.  */
 923
 924 static gfc_expr *
 925 is_conversion (gfc_expr *expr, bool widening)
 926 {
 927   gfc_typespec *ts1, *ts2;
 928
 929   if (expr->expr_type != EXPR_FUNCTION
 930       || expr->value.function.isym == NULL
 931       || expr->value.function.esym != NULL
 932       || expr->value.function.isym->generic_id != GFC_ISYM_CONVERSION)
 933     return NULL;
 934
 935   if (widening)
 936     {
 937       ts1 = &expr->ts;
 938       ts2 = &expr->value.function.actual->expr->ts;
 939     }
 940   else
 941     {
 942       ts1 = &expr->value.function.actual->expr->ts;
 943       ts2 = &expr->ts;
 944     }
 945
 946   if (ts1->type > ts2->type
 947       || (ts1->type == ts2->type && ts1->kind > ts2->kind))
 948     return expr->value.function.actual->expr;
 949
 950   return NULL;
 951 }
 952
 953 static void
 954 resolve_omp_atomic (gfc_code *code)
 955 {
 956   gfc_symbol *var;
 957   gfc_expr *expr2;
 958
 959   code = code->block->next;
 960   gcc_assert (code->op == EXEC_ASSIGN);
 961   gcc_assert (code->next == NULL);
 962
 963   if (code->expr->expr_type != EXPR_VARIABLE
 964       || code->expr->symtree == NULL
 965       || code->expr->rank != 0
 966       || (code->expr->ts.type != BT_INTEGER
 967           && code->expr->ts.type != BT_REAL
 968           && code->expr->ts.type != BT_COMPLEX
 969           && code->expr->ts.type != BT_LOGICAL))
 970     {
 971       gfc_error ("!$OMP ATOMIC statement must set a scalar variable of"
 972                  " intrinsic type at %L", &code->loc);
 973       return;
 974     }
 975
 976   var = code->expr->symtree->n.sym;
 977   expr2 = is_conversion (code->expr2, false);
 978   if (expr2 == NULL)
 979     expr2 = code->expr2;
 980
 981   if (expr2->expr_type == EXPR_OP)
 982     {
 983       gfc_expr *v = NULL, *e, *c;
 984       gfc_intrinsic_op op = expr2->value.op.operator;
 985       gfc_intrinsic_op alt_op = INTRINSIC_NONE;
 986
 987       switch (op)
 988         {
 989         case INTRINSIC_PLUS:
 990           alt_op = INTRINSIC_MINUS;
 991           break;
 992         case INTRINSIC_TIMES:
 993           alt_op = INTRINSIC_DIVIDE;
 994           break;
 995         case INTRINSIC_MINUS:
 996           alt_op = INTRINSIC_PLUS;
 997           break;
 998         case INTRINSIC_DIVIDE:
 999           alt_op = INTRINSIC_TIMES;
1000           break;
1001         case INTRINSIC_AND:
1002         case INTRINSIC_OR:
1003           break;
1004         case INTRINSIC_EQV:
1005           alt_op = INTRINSIC_NEQV;
1006           break;
1007         case INTRINSIC_NEQV:
1008           alt_op = INTRINSIC_EQV;
1009           break;
1010         default:
1011           gfc_error ("!$OMP ATOMIC assignment operator must be"
1012                      " +, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
1013                      &expr2->where);
1014           return;
1015         }
1016
1017       /* Check for var = var op expr resp. var = expr op var where
1018          expr doesn't reference var and var op expr is mathematically
1019          equivalent to var op (expr) resp. expr op var equivalent to
1020          (expr) op var.  We rely here on the fact that the matcher
1021          for x op1 y op2 z where op1 and op2 have equal precedence
1022          returns (x op1 y) op2 z.  */
1023       e = expr2->value.op.op2;
1024       if (e->expr_type == EXPR_VARIABLE
1025           && e->symtree != NULL
1026           && e->symtree->n.sym == var)
1027         v = e;
1028       else if ((c = is_conversion (e, true)) != NULL
1029                && c->expr_type == EXPR_VARIABLE
1030                && c->symtree != NULL
1031                && c->symtree->n.sym == var)
1032         v = c;
1033       else
1034         {
1035           gfc_expr **p = NULL, **q;
1036           for (q = &expr2->value.op.op1; (e = *q) != NULL; )
1037             if (e->expr_type == EXPR_VARIABLE
1038                 && e->symtree != NULL
1039                 && e->symtree->n.sym == var)
1040               {
1041                 v = e;
1042                 break;
1043               }
1044             else if ((c = is_conversion (e, true)) != NULL)
1045               q = &e->value.function.actual->expr;
1046             else if (e->expr_type != EXPR_OP
1047                      || (e->value.op.operator != op
1048                          && e->value.op.operator != alt_op)
1049                      || e->rank != 0)
1050               break;
1051             else
1052               {
1053                 p = q;
1054                 q = &e->value.op.op1;
1055               }
1056
1057           if (v == NULL)
1058             {
1059               gfc_error ("!$OMP ATOMIC assignment must be var = var op expr"
1060                          " or var = expr op var at %L", &expr2->where);
1061               return;
1062             }
1063
1064           if (p != NULL)
1065             {
1066               e = *p;
1067               switch (e->value.op.operator)
1068                 {
1069                 case INTRINSIC_MINUS:
1070                 case INTRINSIC_DIVIDE:
1071                 case INTRINSIC_EQV:
1072                 case INTRINSIC_NEQV:
1073                   gfc_error ("!$OMP ATOMIC var = var op expr not"
1074                              " mathematically equivalent to var = var op"
1075                              " (expr) at %L", &expr2->where);
1076                   break;
1077                 default:
1078                   break;
1079                 }
1080
1081               /* Canonicalize into var = var op (expr).  */
1082               *p = e->value.op.op2;
1083               e->value.op.op2 = expr2;
1084               e->ts = expr2->ts;
1085               if (code->expr2 == expr2)
1086                 code->expr2 = expr2 = e;
1087               else
1088                 code->expr2->value.function.actual->expr = expr2 = e;
1089
1090               if (!gfc_compare_types (&expr2->value.op.op1->ts, &expr2->ts))
1091                 {
1092                   for (p = &expr2->value.op.op1; *p != v;
1093                        p = &(*p)->value.function.actual->expr)
1094                     ;
1095                   *p = NULL;
1096                   gfc_free_expr (expr2->value.op.op1);
1097                   expr2->value.op.op1 = v;
1098                   gfc_convert_type (v, &expr2->ts, 2);
1099                 }
1100             }
1101         }
1102
1103       if (e->rank != 0 || expr_references_sym (code->expr2, var, v))
1104         {
1105           gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr"
1106                      " must be scalar and cannot reference var at %L",
1107                      &expr2->where);
1108           return;
1109         }
1110     }
1111   else if (expr2->expr_type == EXPR_FUNCTION
1112            && expr2->value.function.isym != NULL
1113            && expr2->value.function.esym == NULL
1114            && expr2->value.function.actual != NULL
1115            && expr2->value.function.actual->next != NULL)
1116     {
1117       gfc_actual_arglist *arg, *var_arg;
1118
1119       switch (expr2->value.function.isym->generic_id)
1120         {
1121         case GFC_ISYM_MIN:
1122         case GFC_ISYM_MAX:
1123           break;
1124         case GFC_ISYM_IAND:
1125         case GFC_ISYM_IOR:
1126         case GFC_ISYM_IEOR:
1127           if (expr2->value.function.actual->next->next != NULL)
1128             {
1129               gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR"
1130                          "or IEOR must have two arguments at %L",
1131                          &expr2->where);
1132               return;
1133             }
1134           break;
1135         default:
1136           gfc_error ("!$OMP ATOMIC assignment intrinsic must be"
1137                      " MIN, MAX, IAND, IOR or IEOR at %L",
1138                      &expr2->where);
1139           return;
1140         }
1141
1142       var_arg = NULL;
1143       for (arg = expr2->value.function.actual; arg; arg = arg->next)
1144         {
1145           if ((arg == expr2->value.function.actual
1146                || (var_arg == NULL && arg->next == NULL))
1147               && arg->expr->expr_type == EXPR_VARIABLE
1148               && arg->expr->symtree != NULL
1149               && arg->expr->symtree->n.sym == var)
1150             var_arg = arg;
1151           else if (expr_references_sym (arg->expr, var, NULL))
1152             gfc_error ("!$OMP ATOMIC intrinsic arguments except one must not"
1153                        " reference '%s' at %L", var->name, &arg->expr->where);
1154           if (arg->expr->rank != 0)
1155             gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar"
1156                        " at %L", &arg->expr->where);
1157         }
1158
1159       if (var_arg == NULL)
1160         {
1161           gfc_error ("First or last !$OMP ATOMIC intrinsic argument must"
1162                      " be '%s' at %L", var->name, &expr2->where);
1163           return;
1164         }
1165
1166       if (var_arg != expr2->value.function.actual)
1167         {
1168           /* Canonicalize, so that var comes first.  */
1169           gcc_assert (var_arg->next == NULL);
1170           for (arg = expr2->value.function.actual;
1171                arg->next != var_arg; arg = arg->next)
1172             ;
1173           var_arg->next = expr2->value.function.actual;
1174           expr2->value.function.actual = var_arg;
1175           arg->next = NULL;
1176         }
1177     }
1178   else
1179     gfc_error ("!$OMP ATOMIC assignment must have an operator or intrinsic"
1180                " on right hand side at %L", &expr2->where);
1181 }
1182
1183 struct omp_context
1184 {
1185   gfc_code *code;
1186   struct pointer_set_t *sharing_clauses;
1187   struct pointer_set_t *private_iterators;
1188   struct omp_context *previous;
1189 } *omp_current_ctx;
1190 gfc_code *omp_current_do_code;
1191
1192 void
1193 gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
1194 {
1195   if (code->block->next && code->block->next->op == EXEC_DO)
1196     omp_current_do_code = code->block->next;
1197   gfc_resolve_blocks (code->block, ns);
1198 }
1199
1200 void
1201 gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
1202 {
1203   struct omp_context ctx;
1204   gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
1205   gfc_namelist *n;
1206   int list;
1207
1208   ctx.code = code;
1209   ctx.sharing_clauses = pointer_set_create ();
1210   ctx.private_iterators = pointer_set_create ();
1211   ctx.previous = omp_current_ctx;
1212   omp_current_ctx = &ctx;
1213
1214   for (list = 0; list < OMP_LIST_NUM; list++)
1215     for (n = omp_clauses->lists[list]; n; n = n->next)
1216       pointer_set_insert (ctx.sharing_clauses, n->sym);
1217
1218   if (code->op == EXEC_OMP_PARALLEL_DO)
1219     gfc_resolve_omp_do_blocks (code, ns);
1220   else
1221     gfc_resolve_blocks (code->block, ns);
1222
1223   omp_current_ctx = ctx.previous;
1224   pointer_set_destroy (ctx.sharing_clauses);
1225   pointer_set_destroy (ctx.private_iterators);
1226 }
1227
1228 /* Note a DO iterator variable.  This is special in !$omp parallel
1229    construct, where they are predetermined private.  */
1230
1231 void
1232 gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym)
1233 {
1234   struct omp_context *ctx;
1235
1236   if (sym->attr.threadprivate)
1237     return;
1238
1239   /* !$omp do and !$omp parallel do iteration variable is predetermined
1240      private just in the !$omp do resp. !$omp parallel do construct,
1241      with no implications for the outer parallel constructs.  */
1242   if (code == omp_current_do_code)
1243     return;
1244
1245   for (ctx = omp_current_ctx; ctx; ctx = ctx->previous)
1246     {
1247       if (pointer_set_contains (ctx->sharing_clauses, sym))
1248         continue;
1249
1250       if (! pointer_set_insert (ctx->private_iterators, sym))
1251         {
1252           gfc_omp_clauses *omp_clauses = ctx->code->ext.omp_clauses;
1253           gfc_namelist *p;
1254
1255           p = gfc_get_namelist ();
1256           p->sym = sym;
1257           p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
1258           omp_clauses->lists[OMP_LIST_PRIVATE] = p;
1259         }
1260     }
1261 }
1262
1263 static void
1264 resolve_omp_do (gfc_code *code)
1265 {
1266   gfc_code *do_code;
1267   int list;
1268   gfc_namelist *n;
1269   gfc_symbol *dovar;
1270
1271   if (code->ext.omp_clauses)
1272     resolve_omp_clauses (code);
1273
1274   do_code = code->block->next;
1275   if (do_code->op == EXEC_DO_WHILE)
1276     gfc_error ("!$OMP DO cannot be a DO WHILE or DO without loop control at %L",
1277                &do_code->loc);
1278   else
1279     {
1280       gcc_assert (do_code->op == EXEC_DO);
1281       if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
1282         gfc_error ("!$OMP DO iteration variable must be of type integer at %L",
1283                    &do_code->loc);
1284       dovar = do_code->ext.iterator->var->symtree->n.sym;
1285       if (dovar->attr.threadprivate)
1286         gfc_error ("!$OMP DO iteration variable must not be THREADPRIVATE at %L",
1287                    &do_code->loc);
1288       if (code->ext.omp_clauses)
1289         for (list = 0; list < OMP_LIST_NUM; list++)
1290           if (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE)
1291             for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
1292               if (dovar == n->sym)
1293                 {
1294                   gfc_error ("!$OMP DO iteration variable present on clause"
1295                              " other than PRIVATE or LASTPRIVATE at %L",
1296                              &do_code->loc);
1297                   break;
1298                 }
1299     }
1300 }
1301
1302 /* Resolve OpenMP directive clauses and check various requirements
1303    of each directive.  */
1304
1305 void
1306 gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
1307 {
1308   switch (code->op)
1309     {
1310     case EXEC_OMP_DO:
1311     case EXEC_OMP_PARALLEL_DO:
1312       resolve_omp_do (code);
1313       break;
1314     case EXEC_OMP_WORKSHARE:
1315     case EXEC_OMP_PARALLEL_WORKSHARE:
1316     case EXEC_OMP_PARALLEL:
1317     case EXEC_OMP_PARALLEL_SECTIONS:
1318     case EXEC_OMP_SECTIONS:
1319     case EXEC_OMP_SINGLE:
1320       if (code->ext.omp_clauses)
1321         resolve_omp_clauses (code);
1322       break;
1323     case EXEC_OMP_ATOMIC:
1324       resolve_omp_atomic (code);
1325       break;
1326     default:
1327       break;
1328     }
1329 }