gcc/fortran/openmp.c

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