gcc/fortran/trans-openmp.c

   1 /* OpenMP directive translation -- generate GCC trees from gfc_code.
   2    Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010
   3    Free Software Foundation, Inc.
   4    Contributed by Jakub Jelinek <jakub@redhat.com>
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 3, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  */
  21
  22
  23 #include "config.h"
  24 #include "system.h"
  25 #include "coretypes.h"
  26 #include "tree.h"
  27 #include "gimple.h"     /* For create_tmp_var_raw.  */
  28 #include "diagnostic-core.h"    /* For internal_error.  */
  29 #include "gfortran.h"
  30 #include "trans.h"
  31 #include "trans-stmt.h"
  32 #include "trans-types.h"
  33 #include "trans-array.h"
  34 #include "trans-const.h"
  35 #include "arith.h"
  36
  37 int ompws_flags;
  38
  39 /* True if OpenMP should privatize what this DECL points to rather
  40    than the DECL itself.  */
  41
  42 bool
  43 gfc_omp_privatize_by_reference (const_tree decl)
  44 {
  45   tree type = TREE_TYPE (decl);
  46
  47   if (TREE_CODE (type) == REFERENCE_TYPE
  48       && (!DECL_ARTIFICIAL (decl) || TREE_CODE (decl) == PARM_DECL))
  49     return true;
  50
  51   if (TREE_CODE (type) == POINTER_TYPE)
  52     {
  53       /* Array POINTER/ALLOCATABLE have aggregate types, all user variables
  54          that have POINTER_TYPE type and don't have GFC_POINTER_TYPE_P
  55          set are supposed to be privatized by reference.  */
  56       if (GFC_POINTER_TYPE_P (type))
  57         return false;
  58
  59       if (!DECL_ARTIFICIAL (decl)
  60           && TREE_CODE (TREE_TYPE (type)) != FUNCTION_TYPE)
  61         return true;
  62
  63       /* Some arrays are expanded as DECL_ARTIFICIAL pointers
  64          by the frontend.  */
  65       if (DECL_LANG_SPECIFIC (decl)
  66           && GFC_DECL_SAVED_DESCRIPTOR (decl))
  67         return true;
  68     }
  69
  70   return false;
  71 }
  72
  73 /* True if OpenMP sharing attribute of DECL is predetermined.  */
  74
  75 enum omp_clause_default_kind
  76 gfc_omp_predetermined_sharing (tree decl)
  77 {
  78   if (DECL_ARTIFICIAL (decl)
  79       && ! GFC_DECL_RESULT (decl)
  80       && ! (DECL_LANG_SPECIFIC (decl)
  81             && GFC_DECL_SAVED_DESCRIPTOR (decl)))
  82     return OMP_CLAUSE_DEFAULT_SHARED;
  83
  84   /* Cray pointees shouldn't be listed in any clauses and should be
  85      gimplified to dereference of the corresponding Cray pointer.
  86      Make them all private, so that they are emitted in the debug
  87      information.  */
  88   if (GFC_DECL_CRAY_POINTEE (decl))
  89     return OMP_CLAUSE_DEFAULT_PRIVATE;
  90
  91   /* Assumed-size arrays are predetermined to inherit sharing
  92      attributes of the associated actual argument, which is shared
  93      for all we care.  */
  94   if (TREE_CODE (decl) == PARM_DECL
  95       && GFC_ARRAY_TYPE_P (TREE_TYPE (decl))
  96       && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_UNKNOWN
  97       && GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl),
  98                                 GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)) - 1)
  99          == NULL)
 100     return OMP_CLAUSE_DEFAULT_SHARED;
 101
 102   /* Dummy procedures aren't considered variables by OpenMP, thus are
 103      disallowed in OpenMP clauses.  They are represented as PARM_DECLs
 104      in the middle-end, so return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE here
 105      to avoid complaining about their uses with default(none).  */
 106   if (TREE_CODE (decl) == PARM_DECL
 107       && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE
 108       && TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) == FUNCTION_TYPE)
 109     return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
 110
 111   /* COMMON and EQUIVALENCE decls are shared.  They
 112      are only referenced through DECL_VALUE_EXPR of the variables
 113      contained in them.  If those are privatized, they will not be
 114      gimplified to the COMMON or EQUIVALENCE decls.  */
 115   if (GFC_DECL_COMMON_OR_EQUIV (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
 116     return OMP_CLAUSE_DEFAULT_SHARED;
 117
 118   if (GFC_DECL_RESULT (decl) && ! DECL_HAS_VALUE_EXPR_P (decl))
 119     return OMP_CLAUSE_DEFAULT_SHARED;
 120
 121   return OMP_CLAUSE_DEFAULT_UNSPECIFIED;
 122 }
 123
 124 /* Return decl that should be used when reporting DEFAULT(NONE)
 125    diagnostics.  */
 126
 127 tree
 128 gfc_omp_report_decl (tree decl)
 129 {
 130   if (DECL_ARTIFICIAL (decl)
 131       && DECL_LANG_SPECIFIC (decl)
 132       && GFC_DECL_SAVED_DESCRIPTOR (decl))
 133     return GFC_DECL_SAVED_DESCRIPTOR (decl);
 134
 135   return decl;
 136 }
 137
 138 /* Return true if DECL in private clause needs
 139    OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause.  */
 140 bool
 141 gfc_omp_private_outer_ref (tree decl)
 142 {
 143   tree type = TREE_TYPE (decl);
 144
 145   if (GFC_DESCRIPTOR_TYPE_P (type)
 146       && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
 147     return true;
 148
 149   return false;
 150 }
 151
 152 /* Return code to initialize DECL with its default constructor, or
 153    NULL if there's nothing to do.  */
 154
 155 tree
 156 gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer)
 157 {
 158   tree type = TREE_TYPE (decl), rank, size, esize, ptr, cond, then_b, else_b;
 159   stmtblock_t block, cond_block;
 160
 161   if (! GFC_DESCRIPTOR_TYPE_P (type)
 162       || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
 163     return NULL;
 164
 165   gcc_assert (outer != NULL);
 166   gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_PRIVATE
 167               || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LASTPRIVATE);
 168
 169   /* Allocatable arrays in PRIVATE clauses need to be set to
 170      "not currently allocated" allocation status if outer
 171      array is "not currently allocated", otherwise should be allocated.  */
 172   gfc_start_block (&block);
 173
 174   gfc_init_block (&cond_block);
 175
 176   gfc_add_modify (&cond_block, decl, outer);
 177   rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
 178   size = gfc_conv_descriptor_ubound_get (decl, rank);
 179   size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
 180                           size, gfc_conv_descriptor_lbound_get (decl, rank));
 181   size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
 182                           size, gfc_index_one_node);
 183   if (GFC_TYPE_ARRAY_RANK (type) > 1)
 184     size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
 185                             size, gfc_conv_descriptor_stride_get (decl, rank));
 186   esize = fold_convert (gfc_array_index_type,
 187                         TYPE_SIZE_UNIT (gfc_get_element_type (type)));
 188   size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
 189                           size, esize);
 190   size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block);
 191   ptr = gfc_allocate_array_with_status (&cond_block,
 192                                         build_int_cst (pvoid_type_node, 0),
 193                                         size, NULL, NULL);
 194   gfc_conv_descriptor_data_set (&cond_block, decl, ptr);
 195   then_b = gfc_finish_block (&cond_block);
 196
 197   gfc_init_block (&cond_block);
 198   gfc_conv_descriptor_data_set (&cond_block, decl, null_pointer_node);
 199   else_b = gfc_finish_block (&cond_block);
 200
 201   cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
 202                           fold_convert (pvoid_type_node,
 203                                         gfc_conv_descriptor_data_get (outer)),
 204                           null_pointer_node);
 205   gfc_add_expr_to_block (&block, build3 (COND_EXPR, void_type_node,
 206                          cond, then_b, else_b));
 207
 208   return gfc_finish_block (&block);
 209 }
 210
 211 /* Build and return code for a copy constructor from SRC to DEST.  */
 212
 213 tree
 214 gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
 215 {
 216   tree type = TREE_TYPE (dest), ptr, size, esize, rank, call;
 217   stmtblock_t block;
 218
 219   if (! GFC_DESCRIPTOR_TYPE_P (type)
 220       || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
 221     return build2_v (MODIFY_EXPR, dest, src);
 222
 223   gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE);
 224
 225   /* Allocatable arrays in FIRSTPRIVATE clauses need to be allocated
 226      and copied from SRC.  */
 227   gfc_start_block (&block);
 228
 229   gfc_add_modify (&block, dest, src);
 230   rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
 231   size = gfc_conv_descriptor_ubound_get (dest, rank);
 232   size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
 233                           size, gfc_conv_descriptor_lbound_get (dest, rank));
 234   size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
 235                           size, gfc_index_one_node);
 236   if (GFC_TYPE_ARRAY_RANK (type) > 1)
 237     size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
 238                             size, gfc_conv_descriptor_stride_get (dest, rank));
 239   esize = fold_convert (gfc_array_index_type,
 240                         TYPE_SIZE_UNIT (gfc_get_element_type (type)));
 241   size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
 242                           size, esize);
 243   size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
 244   ptr = gfc_allocate_array_with_status (&block,
 245                                         build_int_cst (pvoid_type_node, 0),
 246                                         size, NULL, NULL);
 247   gfc_conv_descriptor_data_set (&block, dest, ptr);
 248   call = build_call_expr_loc (input_location,
 249                           built_in_decls[BUILT_IN_MEMCPY], 3, ptr,
 250                           fold_convert (pvoid_type_node,
 251                                         gfc_conv_descriptor_data_get (src)),
 252                           size);
 253   gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
 254
 255   return gfc_finish_block (&block);
 256 }
 257
 258 /* Similarly, except use an assignment operator instead.  */
 259
 260 tree
 261 gfc_omp_clause_assign_op (tree clause ATTRIBUTE_UNUSED, tree dest, tree src)
 262 {
 263   tree type = TREE_TYPE (dest), rank, size, esize, call;
 264   stmtblock_t block;
 265
 266   if (! GFC_DESCRIPTOR_TYPE_P (type)
 267       || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
 268     return build2_v (MODIFY_EXPR, dest, src);
 269
 270   /* Handle copying allocatable arrays.  */
 271   gfc_start_block (&block);
 272
 273   rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
 274   size = gfc_conv_descriptor_ubound_get (dest, rank);
 275   size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
 276                           size, gfc_conv_descriptor_lbound_get (dest, rank));
 277   size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
 278                           size, gfc_index_one_node);
 279   if (GFC_TYPE_ARRAY_RANK (type) > 1)
 280     size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
 281                             size, gfc_conv_descriptor_stride_get (dest, rank));
 282   esize = fold_convert (gfc_array_index_type,
 283                         TYPE_SIZE_UNIT (gfc_get_element_type (type)));
 284   size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
 285                           size, esize);
 286   size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
 287   call = build_call_expr_loc (input_location,
 288                           built_in_decls[BUILT_IN_MEMCPY], 3,
 289                           fold_convert (pvoid_type_node,
 290                                         gfc_conv_descriptor_data_get (dest)),
 291                           fold_convert (pvoid_type_node,
 292                                         gfc_conv_descriptor_data_get (src)),
 293                           size);
 294   gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
 295
 296   return gfc_finish_block (&block);
 297 }
 298
 299 /* Build and return code destructing DECL.  Return NULL if nothing
 300    to be done.  */
 301
 302 tree
 303 gfc_omp_clause_dtor (tree clause ATTRIBUTE_UNUSED, tree decl)
 304 {
 305   tree type = TREE_TYPE (decl);
 306
 307   if (! GFC_DESCRIPTOR_TYPE_P (type)
 308       || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
 309     return NULL;
 310
 311   /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
 312      to be deallocated if they were allocated.  */
 313   return gfc_trans_dealloc_allocated (decl);
 314 }
 315
 316
 317 /* Return true if DECL's DECL_VALUE_EXPR (if any) should be
 318    disregarded in OpenMP construct, because it is going to be
 319    remapped during OpenMP lowering.  SHARED is true if DECL
 320    is going to be shared, false if it is going to be privatized.  */
 321
 322 bool
 323 gfc_omp_disregard_value_expr (tree decl, bool shared)
 324 {
 325   if (GFC_DECL_COMMON_OR_EQUIV (decl)
 326       && DECL_HAS_VALUE_EXPR_P (decl))
 327     {
 328       tree value = DECL_VALUE_EXPR (decl);
 329
 330       if (TREE_CODE (value) == COMPONENT_REF
 331           && TREE_CODE (TREE_OPERAND (value, 0)) == VAR_DECL
 332           && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
 333         {
 334           /* If variable in COMMON or EQUIVALENCE is privatized, return
 335              true, as just that variable is supposed to be privatized,
 336              not the whole COMMON or whole EQUIVALENCE.
 337              For shared variables in COMMON or EQUIVALENCE, let them be
 338              gimplified to DECL_VALUE_EXPR, so that for multiple shared vars
 339              from the same COMMON or EQUIVALENCE just one sharing of the
 340              whole COMMON or EQUIVALENCE is enough.  */
 341           return ! shared;
 342         }
 343     }
 344
 345   if (GFC_DECL_RESULT (decl) && DECL_HAS_VALUE_EXPR_P (decl))
 346     return ! shared;
 347
 348   return false;
 349 }
 350
 351 /* Return true if DECL that is shared iff SHARED is true should
 352    be put into OMP_CLAUSE_PRIVATE with OMP_CLAUSE_PRIVATE_DEBUG
 353    flag set.  */
 354
 355 bool
 356 gfc_omp_private_debug_clause (tree decl, bool shared)
 357 {
 358   if (GFC_DECL_CRAY_POINTEE (decl))
 359     return true;
 360
 361   if (GFC_DECL_COMMON_OR_EQUIV (decl)
 362       && DECL_HAS_VALUE_EXPR_P (decl))
 363     {
 364       tree value = DECL_VALUE_EXPR (decl);
 365
 366       if (TREE_CODE (value) == COMPONENT_REF
 367           && TREE_CODE (TREE_OPERAND (value, 0)) == VAR_DECL
 368           && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0)))
 369         return shared;
 370     }
 371
 372   return false;
 373 }
 374
 375 /* Register language specific type size variables as potentially OpenMP
 376    firstprivate variables.  */
 377
 378 void
 379 gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *ctx, tree type)
 380 {
 381   if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
 382     {
 383       int r;
 384
 385       gcc_assert (TYPE_LANG_SPECIFIC (type) != NULL);
 386       for (r = 0; r < GFC_TYPE_ARRAY_RANK (type); r++)
 387         {
 388           omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_LBOUND (type, r));
 389           omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_UBOUND (type, r));
 390           omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_STRIDE (type, r));
 391         }
 392       omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_SIZE (type));
 393       omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_OFFSET (type));
 394     }
 395 }
 396
 397
 398 static inline tree
 399 gfc_trans_add_clause (tree node, tree tail)
 400 {
 401   OMP_CLAUSE_CHAIN (node) = tail;
 402   return node;
 403 }
 404
 405 static tree
 406 gfc_trans_omp_variable (gfc_symbol *sym)
 407 {
 408   tree t = gfc_get_symbol_decl (sym);
 409   tree parent_decl;
 410   int parent_flag;
 411   bool return_value;
 412   bool alternate_entry;
 413   bool entry_master;
 414
 415   return_value = sym->attr.function && sym->result == sym;
 416   alternate_entry = sym->attr.function && sym->attr.entry
 417                     && sym->result == sym;
 418   entry_master = sym->attr.result
 419                  && sym->ns->proc_name->attr.entry_master
 420                  && !gfc_return_by_reference (sym->ns->proc_name);
 421   parent_decl = DECL_CONTEXT (current_function_decl);
 422
 423   if ((t == parent_decl && return_value)
 424        || (sym->ns && sym->ns->proc_name
 425            && sym->ns->proc_name->backend_decl == parent_decl
 426            && (alternate_entry || entry_master)))
 427     parent_flag = 1;
 428   else
 429     parent_flag = 0;
 430
 431   /* Special case for assigning the return value of a function.
 432      Self recursive functions must have an explicit return value.  */
 433   if (return_value && (t == current_function_decl || parent_flag))
 434     t = gfc_get_fake_result_decl (sym, parent_flag);
 435
 436   /* Similarly for alternate entry points.  */
 437   else if (alternate_entry
 438            && (sym->ns->proc_name->backend_decl == current_function_decl
 439                || parent_flag))
 440     {
 441       gfc_entry_list *el = NULL;
 442
 443       for (el = sym->ns->entries; el; el = el->next)
 444         if (sym == el->sym)
 445           {
 446             t = gfc_get_fake_result_decl (sym, parent_flag);
 447             break;
 448           }
 449     }
 450
 451   else if (entry_master
 452            && (sym->ns->proc_name->backend_decl == current_function_decl
 453                || parent_flag))
 454     t = gfc_get_fake_result_decl (sym, parent_flag);
 455
 456   return t;
 457 }
 458
 459 static tree
 460 gfc_trans_omp_variable_list (enum omp_clause_code code, gfc_namelist *namelist,
 461                              tree list)
 462 {
 463   for (; namelist != NULL; namelist = namelist->next)
 464     if (namelist->sym->attr.referenced)
 465       {
 466         tree t = gfc_trans_omp_variable (namelist->sym);
 467         if (t != error_mark_node)
 468           {
 469             tree node = build_omp_clause (input_location, code);
 470             OMP_CLAUSE_DECL (node) = t;
 471             list = gfc_trans_add_clause (node, list);
 472           }
 473       }
 474   return list;
 475 }
 476
 477 static void
 478 gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
 479 {
 480   gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL;
 481   gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL;
 482   gfc_symbol init_val_sym, outer_sym, intrinsic_sym;
 483   gfc_expr *e1, *e2, *e3, *e4;
 484   gfc_ref *ref;
 485   tree decl, backend_decl, stmt;
 486   locus old_loc = gfc_current_locus;
 487   const char *iname;
 488   gfc_try t;
 489
 490   decl = OMP_CLAUSE_DECL (c);
 491   gfc_current_locus = where;
 492
 493   /* Create a fake symbol for init value.  */
 494   memset (&init_val_sym, 0, sizeof (init_val_sym));
 495   init_val_sym.ns = sym->ns;
 496   init_val_sym.name = sym->name;
 497   init_val_sym.ts = sym->ts;
 498   init_val_sym.attr.referenced = 1;
 499   init_val_sym.declared_at = where;
 500   init_val_sym.attr.flavor = FL_VARIABLE;
 501   backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym));
 502   init_val_sym.backend_decl = backend_decl;
 503
 504   /* Create a fake symbol for the outer array reference.  */
 505   outer_sym = *sym;
 506   outer_sym.as = gfc_copy_array_spec (sym->as);
 507   outer_sym.attr.dummy = 0;
 508   outer_sym.attr.result = 0;
 509   outer_sym.attr.flavor = FL_VARIABLE;
 510   outer_sym.backend_decl = create_tmp_var_raw (TREE_TYPE (decl), NULL);
 511
 512   /* Create fake symtrees for it.  */
 513   symtree1 = gfc_new_symtree (&root1, sym->name);
 514   symtree1->n.sym = sym;
 515   gcc_assert (symtree1 == root1);
 516
 517   symtree2 = gfc_new_symtree (&root2, sym->name);
 518   symtree2->n.sym = &init_val_sym;
 519   gcc_assert (symtree2 == root2);
 520
 521   symtree3 = gfc_new_symtree (&root3, sym->name);
 522   symtree3->n.sym = &outer_sym;
 523   gcc_assert (symtree3 == root3);
 524
 525   /* Create expressions.  */
 526   e1 = gfc_get_expr ();
 527   e1->expr_type = EXPR_VARIABLE;
 528   e1->where = where;
 529   e1->symtree = symtree1;
 530   e1->ts = sym->ts;
 531   e1->ref = ref = gfc_get_ref ();
 532   ref->type = REF_ARRAY;
 533   ref->u.ar.where = where;
 534   ref->u.ar.as = sym->as;
 535   ref->u.ar.type = AR_FULL;
 536   ref->u.ar.dimen = 0;
 537   t = gfc_resolve_expr (e1);
 538   gcc_assert (t == SUCCESS);
 539
 540   e2 = gfc_get_expr ();
 541   e2->expr_type = EXPR_VARIABLE;
 542   e2->where = where;
 543   e2->symtree = symtree2;
 544   e2->ts = sym->ts;
 545   t = gfc_resolve_expr (e2);
 546   gcc_assert (t == SUCCESS);
 547
 548   e3 = gfc_copy_expr (e1);
 549   e3->symtree = symtree3;
 550   t = gfc_resolve_expr (e3);
 551   gcc_assert (t == SUCCESS);
 552
 553   iname = NULL;
 554   switch (OMP_CLAUSE_REDUCTION_CODE (c))
 555     {
 556     case PLUS_EXPR:
 557     case MINUS_EXPR:
 558       e4 = gfc_add (e3, e1);
 559       break;
 560     case MULT_EXPR:
 561       e4 = gfc_multiply (e3, e1);
 562       break;
 563     case TRUTH_ANDIF_EXPR:
 564       e4 = gfc_and (e3, e1);
 565       break;
 566     case TRUTH_ORIF_EXPR:
 567       e4 = gfc_or (e3, e1);
 568       break;
 569     case EQ_EXPR:
 570       e4 = gfc_eqv (e3, e1);
 571       break;
 572     case NE_EXPR:
 573       e4 = gfc_neqv (e3, e1);
 574       break;
 575     case MIN_EXPR:
 576       iname = "min";
 577       break;
 578     case MAX_EXPR:
 579       iname = "max";
 580       break;
 581     case BIT_AND_EXPR:
 582       iname = "iand";
 583       break;
 584     case BIT_IOR_EXPR:
 585       iname = "ior";
 586       break;
 587     case BIT_XOR_EXPR:
 588       iname = "ieor";
 589       break;
 590     default:
 591       gcc_unreachable ();
 592     }
 593   if (iname != NULL)
 594     {
 595       memset (&intrinsic_sym, 0, sizeof (intrinsic_sym));
 596       intrinsic_sym.ns = sym->ns;
 597       intrinsic_sym.name = iname;
 598       intrinsic_sym.ts = sym->ts;
 599       intrinsic_sym.attr.referenced = 1;
 600       intrinsic_sym.attr.intrinsic = 1;
 601       intrinsic_sym.attr.function = 1;
 602       intrinsic_sym.result = &intrinsic_sym;
 603       intrinsic_sym.declared_at = where;
 604
 605       symtree4 = gfc_new_symtree (&root4, iname);
 606       symtree4->n.sym = &intrinsic_sym;
 607       gcc_assert (symtree4 == root4);
 608
 609       e4 = gfc_get_expr ();
 610       e4->expr_type = EXPR_FUNCTION;
 611       e4->where = where;
 612       e4->symtree = symtree4;
 613       e4->value.function.isym = gfc_find_function (iname);
 614       e4->value.function.actual = gfc_get_actual_arglist ();
 615       e4->value.function.actual->expr = e3;
 616       e4->value.function.actual->next = gfc_get_actual_arglist ();
 617       e4->value.function.actual->next->expr = e1;
 618     }
 619   /* e1 and e3 have been stored as arguments of e4, avoid sharing.  */
 620   e1 = gfc_copy_expr (e1);
 621   e3 = gfc_copy_expr (e3);
 622   t = gfc_resolve_expr (e4);
 623   gcc_assert (t == SUCCESS);
 624
 625   /* Create the init statement list.  */
 626   pushlevel (0);
 627   if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
 628       && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_ALLOCATABLE)
 629     {
 630       /* If decl is an allocatable array, it needs to be allocated
 631          with the same bounds as the outer var.  */
 632       tree type = TREE_TYPE (decl), rank, size, esize, ptr;
 633       stmtblock_t block;
 634
 635       gfc_start_block (&block);
 636
 637       gfc_add_modify (&block, decl, outer_sym.backend_decl);
 638       rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
 639       size = gfc_conv_descriptor_ubound_get (decl, rank);
 640       size = fold_build2_loc (input_location, MINUS_EXPR,
 641                               gfc_array_index_type, size,
 642                               gfc_conv_descriptor_lbound_get (decl, rank));
 643       size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
 644                               size, gfc_index_one_node);
 645       if (GFC_TYPE_ARRAY_RANK (type) > 1)
 646         size = fold_build2_loc (input_location, MULT_EXPR,
 647                                 gfc_array_index_type, size,
 648                                 gfc_conv_descriptor_stride_get (decl, rank));
 649       esize = fold_convert (gfc_array_index_type,
 650                             TYPE_SIZE_UNIT (gfc_get_element_type (type)));
 651       size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
 652                               size, esize);
 653       size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
 654       ptr = gfc_allocate_array_with_status (&block,
 655                                             build_int_cst (pvoid_type_node, 0),
 656                                             size, NULL, NULL);
 657       gfc_conv_descriptor_data_set (&block, decl, ptr);
 658       gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false,
 659                              false));
 660       stmt = gfc_finish_block (&block);
 661     }
 662   else
 663     stmt = gfc_trans_assignment (e1, e2, false, false);
 664   if (TREE_CODE (stmt) != BIND_EXPR)
 665     stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
 666   else
 667     poplevel (0, 0, 0);
 668   OMP_CLAUSE_REDUCTION_INIT (c) = stmt;
 669
 670   /* Create the merge statement list.  */
 671   pushlevel (0);
 672   if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
 673       && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_ALLOCATABLE)
 674     {
 675       /* If decl is an allocatable array, it needs to be deallocated
 676          afterwards.  */
 677       stmtblock_t block;
 678
 679       gfc_start_block (&block);
 680       gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false,
 681                              true));
 682       gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl));
 683       stmt = gfc_finish_block (&block);
 684     }
 685   else
 686     stmt = gfc_trans_assignment (e3, e4, false, true);
 687   if (TREE_CODE (stmt) != BIND_EXPR)
 688     stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
 689   else
 690     poplevel (0, 0, 0);
 691   OMP_CLAUSE_REDUCTION_MERGE (c) = stmt;
 692
 693   /* And stick the placeholder VAR_DECL into the clause as well.  */
 694   OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_sym.backend_decl;
 695
 696   gfc_current_locus = old_loc;
 697
 698   gfc_free_expr (e1);
 699   gfc_free_expr (e2);
 700   gfc_free_expr (e3);
 701   gfc_free_expr (e4);
 702   gfc_free (symtree1);
 703   gfc_free (symtree2);
 704   gfc_free (symtree3);
 705   if (symtree4)
 706     gfc_free (symtree4);
 707   gfc_free_array_spec (outer_sym.as);
 708 }
 709
 710 static tree
 711 gfc_trans_omp_reduction_list (gfc_namelist *namelist, tree list,
 712                               enum tree_code reduction_code, locus where)
 713 {
 714   for (; namelist != NULL; namelist = namelist->next)
 715     if (namelist->sym->attr.referenced)
 716       {
 717         tree t = gfc_trans_omp_variable (namelist->sym);
 718         if (t != error_mark_node)
 719           {
 720             tree node = build_omp_clause (where.lb->location,
 721                                           OMP_CLAUSE_REDUCTION);
 722             OMP_CLAUSE_DECL (node) = t;
 723             OMP_CLAUSE_REDUCTION_CODE (node) = reduction_code;
 724             if (namelist->sym->attr.dimension)
 725               gfc_trans_omp_array_reduction (node, namelist->sym, where);
 726             list = gfc_trans_add_clause (node, list);
 727           }
 728       }
 729   return list;
 730 }
 731
 732 static tree
 733 gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
 734                        locus where)
 735 {
 736   tree omp_clauses = NULL_TREE, chunk_size, c;
 737   int list;
 738   enum omp_clause_code clause_code;
 739   gfc_se se;
 740
 741   if (clauses == NULL)
 742     return NULL_TREE;
 743
 744   for (list = 0; list < OMP_LIST_NUM; list++)
 745     {
 746       gfc_namelist *n = clauses->lists[list];
 747
 748       if (n == NULL)
 749         continue;
 750       if (list >= OMP_LIST_REDUCTION_FIRST
 751           && list <= OMP_LIST_REDUCTION_LAST)
 752         {
 753           enum tree_code reduction_code;
 754           switch (list)
 755             {
 756             case OMP_LIST_PLUS:
 757               reduction_code = PLUS_EXPR;
 758               break;
 759             case OMP_LIST_MULT:
 760               reduction_code = MULT_EXPR;
 761               break;
 762             case OMP_LIST_SUB:
 763               reduction_code = MINUS_EXPR;
 764               break;
 765             case OMP_LIST_AND:
 766               reduction_code = TRUTH_ANDIF_EXPR;
 767               break;
 768             case OMP_LIST_OR:
 769               reduction_code = TRUTH_ORIF_EXPR;
 770               break;
 771             case OMP_LIST_EQV:
 772               reduction_code = EQ_EXPR;
 773               break;
 774             case OMP_LIST_NEQV:
 775               reduction_code = NE_EXPR;
 776               break;
 777             case OMP_LIST_MAX:
 778               reduction_code = MAX_EXPR;
 779               break;
 780             case OMP_LIST_MIN:
 781               reduction_code = MIN_EXPR;
 782               break;
 783             case OMP_LIST_IAND:
 784               reduction_code = BIT_AND_EXPR;
 785               break;
 786             case OMP_LIST_IOR:
 787               reduction_code = BIT_IOR_EXPR;
 788               break;
 789             case OMP_LIST_IEOR:
 790               reduction_code = BIT_XOR_EXPR;
 791               break;
 792             default:
 793               gcc_unreachable ();
 794             }
 795           omp_clauses
 796             = gfc_trans_omp_reduction_list (n, omp_clauses, reduction_code,
 797                                             where);
 798           continue;
 799         }
 800       switch (list)
 801         {
 802         case OMP_LIST_PRIVATE:
 803           clause_code = OMP_CLAUSE_PRIVATE;
 804           goto add_clause;
 805         case OMP_LIST_SHARED:
 806           clause_code = OMP_CLAUSE_SHARED;
 807           goto add_clause;
 808         case OMP_LIST_FIRSTPRIVATE:
 809           clause_code = OMP_CLAUSE_FIRSTPRIVATE;
 810           goto add_clause;
 811         case OMP_LIST_LASTPRIVATE:
 812           clause_code = OMP_CLAUSE_LASTPRIVATE;
 813           goto add_clause;
 814         case OMP_LIST_COPYIN:
 815           clause_code = OMP_CLAUSE_COPYIN;
 816           goto add_clause;
 817         case OMP_LIST_COPYPRIVATE:
 818           clause_code = OMP_CLAUSE_COPYPRIVATE;
 819           /* FALLTHROUGH */
 820         add_clause:
 821           omp_clauses
 822             = gfc_trans_omp_variable_list (clause_code, n, omp_clauses);
 823           break;
 824         default:
 825           break;
 826         }
 827     }
 828
 829   if (clauses->if_expr)
 830     {
 831       tree if_var;
 832
 833       gfc_init_se (&se, NULL);
 834       gfc_conv_expr (&se, clauses->if_expr);
 835       gfc_add_block_to_block (block, &se.pre);
 836       if_var = gfc_evaluate_now (se.expr, block);
 837       gfc_add_block_to_block (block, &se.post);
 838
 839       c = build_omp_clause (where.lb->location, OMP_CLAUSE_IF);
 840       OMP_CLAUSE_IF_EXPR (c) = if_var;
 841       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
 842     }
 843
 844   if (clauses->num_threads)
 845     {
 846       tree num_threads;
 847
 848       gfc_init_se (&se, NULL);
 849       gfc_conv_expr (&se, clauses->num_threads);
 850       gfc_add_block_to_block (block, &se.pre);
 851       num_threads = gfc_evaluate_now (se.expr, block);
 852       gfc_add_block_to_block (block, &se.post);
 853
 854       c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_THREADS);
 855       OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads;
 856       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
 857     }
 858
 859   chunk_size = NULL_TREE;
 860   if (clauses->chunk_size)
 861     {
 862       gfc_init_se (&se, NULL);
 863       gfc_conv_expr (&se, clauses->chunk_size);
 864       gfc_add_block_to_block (block, &se.pre);
 865       chunk_size = gfc_evaluate_now (se.expr, block);
 866       gfc_add_block_to_block (block, &se.post);
 867     }
 868
 869   if (clauses->sched_kind != OMP_SCHED_NONE)
 870     {
 871       c = build_omp_clause (where.lb->location, OMP_CLAUSE_SCHEDULE);
 872       OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
 873       switch (clauses->sched_kind)
 874         {
 875         case OMP_SCHED_STATIC:
 876           OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC;
 877           break;
 878         case OMP_SCHED_DYNAMIC:
 879           OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC;
 880           break;
 881         case OMP_SCHED_GUIDED:
 882           OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED;
 883           break;
 884         case OMP_SCHED_RUNTIME:
 885           OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME;
 886           break;
 887         case OMP_SCHED_AUTO:
 888           OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_AUTO;
 889           break;
 890         default:
 891           gcc_unreachable ();
 892         }
 893       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
 894     }
 895
 896   if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
 897     {
 898       c = build_omp_clause (where.lb->location, OMP_CLAUSE_DEFAULT);
 899       switch (clauses->default_sharing)
 900         {
 901         case OMP_DEFAULT_NONE:
 902           OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE;
 903           break;
 904         case OMP_DEFAULT_SHARED:
 905           OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED;
 906           break;
 907         case OMP_DEFAULT_PRIVATE:
 908           OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE;
 909           break;
 910         case OMP_DEFAULT_FIRSTPRIVATE:
 911           OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
 912           break;
 913         default:
 914           gcc_unreachable ();
 915         }
 916       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
 917     }
 918
 919   if (clauses->nowait)
 920     {
 921       c = build_omp_clause (where.lb->location, OMP_CLAUSE_NOWAIT);
 922       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
 923     }
 924
 925   if (clauses->ordered)
 926     {
 927       c = build_omp_clause (where.lb->location, OMP_CLAUSE_ORDERED);
 928       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
 929     }
 930
 931   if (clauses->untied)
 932     {
 933       c = build_omp_clause (where.lb->location, OMP_CLAUSE_UNTIED);
 934       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
 935     }
 936
 937   if (clauses->collapse)
 938     {
 939       c = build_omp_clause (where.lb->location, OMP_CLAUSE_COLLAPSE);
 940       OMP_CLAUSE_COLLAPSE_EXPR (c) = build_int_cst (NULL, clauses->collapse);
 941       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
 942     }
 943
 944   return omp_clauses;
 945 }
 946
 947 /* Like gfc_trans_code, but force creation of a BIND_EXPR around it.  */
 948
 949 static tree
 950 gfc_trans_omp_code (gfc_code *code, bool force_empty)
 951 {
 952   tree stmt;
 953
 954   pushlevel (0);
 955   stmt = gfc_trans_code (code);
 956   if (TREE_CODE (stmt) != BIND_EXPR)
 957     {
 958       if (!IS_EMPTY_STMT (stmt) || force_empty)
 959         {
 960           tree block = poplevel (1, 0, 0);
 961           stmt = build3_v (BIND_EXPR, NULL, stmt, block);
 962         }
 963       else
 964         poplevel (0, 0, 0);
 965     }
 966   else
 967     poplevel (0, 0, 0);
 968   return stmt;
 969 }
 970
 971
 972 static tree gfc_trans_omp_sections (gfc_code *, gfc_omp_clauses *);
 973 static tree gfc_trans_omp_workshare (gfc_code *, gfc_omp_clauses *);
 974
 975 static tree
 976 gfc_trans_omp_atomic (gfc_code *code)
 977 {
 978   gfc_se lse;
 979   gfc_se rse;
 980   gfc_expr *expr2, *e;
 981   gfc_symbol *var;
 982   stmtblock_t block;
 983   tree lhsaddr, type, rhs, x;
 984   enum tree_code op = ERROR_MARK;
 985   bool var_on_left = false;
 986
 987   code = code->block->next;
 988   gcc_assert (code->op == EXEC_ASSIGN);
 989   gcc_assert (code->next == NULL);
 990   var = code->expr1->symtree->n.sym;
 991
 992   gfc_init_se (&lse, NULL);
 993   gfc_init_se (&rse, NULL);
 994   gfc_start_block (&block);
 995
 996   gfc_conv_expr (&lse, code->expr1);
 997   gfc_add_block_to_block (&block, &lse.pre);
 998   type = TREE_TYPE (lse.expr);
 999   lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
1000
1001   expr2 = code->expr2;
1002   if (expr2->expr_type == EXPR_FUNCTION
1003       && expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
1004     expr2 = expr2->value.function.actual->expr;
1005
1006   if (expr2->expr_type == EXPR_OP)
1007     {
1008       gfc_expr *e;
1009       switch (expr2->value.op.op)
1010         {
1011         case INTRINSIC_PLUS:
1012           op = PLUS_EXPR;
1013           break;
1014         case INTRINSIC_TIMES:
1015           op = MULT_EXPR;
1016           break;
1017         case INTRINSIC_MINUS:
1018           op = MINUS_EXPR;
1019           break;
1020         case INTRINSIC_DIVIDE:
1021           if (expr2->ts.type == BT_INTEGER)
1022             op = TRUNC_DIV_EXPR;
1023           else
1024             op = RDIV_EXPR;
1025           break;
1026         case INTRINSIC_AND:
1027           op = TRUTH_ANDIF_EXPR;
1028           break;
1029         case INTRINSIC_OR:
1030           op = TRUTH_ORIF_EXPR;
1031           break;
1032         case INTRINSIC_EQV:
1033           op = EQ_EXPR;
1034           break;
1035         case INTRINSIC_NEQV:
1036           op = NE_EXPR;
1037           break;
1038         default:
1039           gcc_unreachable ();
1040         }
1041       e = expr2->value.op.op1;
1042       if (e->expr_type == EXPR_FUNCTION
1043           && e->value.function.isym->id == GFC_ISYM_CONVERSION)
1044         e = e->value.function.actual->expr;
1045       if (e->expr_type == EXPR_VARIABLE
1046           && e->symtree != NULL
1047           && e->symtree->n.sym == var)
1048         {
1049           expr2 = expr2->value.op.op2;
1050           var_on_left = true;
1051         }
1052       else
1053         {
1054           e = expr2->value.op.op2;
1055           if (e->expr_type == EXPR_FUNCTION
1056               && e->value.function.isym->id == GFC_ISYM_CONVERSION)
1057             e = e->value.function.actual->expr;
1058           gcc_assert (e->expr_type == EXPR_VARIABLE
1059                       && e->symtree != NULL
1060                       && e->symtree->n.sym == var);
1061           expr2 = expr2->value.op.op1;
1062           var_on_left = false;
1063         }
1064       gfc_conv_expr (&rse, expr2);
1065       gfc_add_block_to_block (&block, &rse.pre);
1066     }
1067   else
1068     {
1069       gcc_assert (expr2->expr_type == EXPR_FUNCTION);
1070       switch (expr2->value.function.isym->id)
1071         {
1072         case GFC_ISYM_MIN:
1073           op = MIN_EXPR;
1074           break;
1075         case GFC_ISYM_MAX:
1076           op = MAX_EXPR;
1077           break;
1078         case GFC_ISYM_IAND:
1079           op = BIT_AND_EXPR;
1080           break;
1081         case GFC_ISYM_IOR:
1082           op = BIT_IOR_EXPR;
1083           break;
1084         case GFC_ISYM_IEOR:
1085           op = BIT_XOR_EXPR;
1086           break;
1087         default:
1088           gcc_unreachable ();
1089         }
1090       e = expr2->value.function.actual->expr;
1091       gcc_assert (e->expr_type == EXPR_VARIABLE
1092                   && e->symtree != NULL
1093                   && e->symtree->n.sym == var);
1094
1095       gfc_conv_expr (&rse, expr2->value.function.actual->next->expr);
1096       gfc_add_block_to_block (&block, &rse.pre);
1097       if (expr2->value.function.actual->next->next != NULL)
1098         {
1099           tree accum = gfc_create_var (TREE_TYPE (rse.expr), NULL);
1100           gfc_actual_arglist *arg;
1101
1102           gfc_add_modify (&block, accum, rse.expr);
1103           for (arg = expr2->value.function.actual->next->next; arg;
1104                arg = arg->next)
1105             {
1106               gfc_init_block (&rse.pre);
1107               gfc_conv_expr (&rse, arg->expr);
1108               gfc_add_block_to_block (&block, &rse.pre);
1109               x = fold_build2_loc (input_location, op, TREE_TYPE (accum),
1110                                    accum, rse.expr);
1111               gfc_add_modify (&block, accum, x);
1112             }
1113
1114           rse.expr = accum;
1115         }
1116
1117       expr2 = expr2->value.function.actual->next->expr;
1118     }
1119
1120   lhsaddr = save_expr (lhsaddr);
1121   rhs = gfc_evaluate_now (rse.expr, &block);
1122   x = convert (TREE_TYPE (rhs), build_fold_indirect_ref_loc (input_location,
1123                                                          lhsaddr));
1124
1125   if (var_on_left)
1126     x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), x, rhs);
1127   else
1128     x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), rhs, x);
1129
1130   if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE
1131       && TREE_CODE (type) != COMPLEX_TYPE)
1132     x = fold_build1_loc (input_location, REALPART_EXPR,
1133                          TREE_TYPE (TREE_TYPE (rhs)), x);
1134
1135   x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x));
1136   gfc_add_expr_to_block (&block, x);
1137
1138   gfc_add_block_to_block (&block, &lse.pre);
1139   gfc_add_block_to_block (&block, &rse.pre);
1140
1141   return gfc_finish_block (&block);
1142 }
1143
1144 static tree
1145 gfc_trans_omp_barrier (void)
1146 {
1147   tree decl = built_in_decls [BUILT_IN_GOMP_BARRIER];
1148   return build_call_expr_loc (input_location, decl, 0);
1149 }
1150
1151 static tree
1152 gfc_trans_omp_critical (gfc_code *code)
1153 {
1154   tree name = NULL_TREE, stmt;
1155   if (code->ext.omp_name != NULL)
1156     name = get_identifier (code->ext.omp_name);
1157   stmt = gfc_trans_code (code->block->next);
1158   return build2 (OMP_CRITICAL, void_type_node, stmt, name);
1159 }
1160
1161 typedef struct dovar_init_d {
1162   tree var;
1163   tree init;
1164 } dovar_init;
1165
1166 DEF_VEC_O(dovar_init);
1167 DEF_VEC_ALLOC_O(dovar_init,heap);
1168
1169 static tree
1170 gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock,
1171                   gfc_omp_clauses *do_clauses, tree par_clauses)
1172 {
1173   gfc_se se;
1174   tree dovar, stmt, from, to, step, type, init, cond, incr;
1175   tree count = NULL_TREE, cycle_label, tmp, omp_clauses;
1176   stmtblock_t block;
1177   stmtblock_t body;
1178   gfc_omp_clauses *clauses = code->ext.omp_clauses;
1179   int i, collapse = clauses->collapse;
1180   VEC(dovar_init,heap) *inits = NULL;
1181   dovar_init *di;
1182   unsigned ix;
1183
1184   if (collapse <= 0)
1185     collapse = 1;
1186
1187   code = code->block->next;
1188   gcc_assert (code->op == EXEC_DO);
1189
1190   init = make_tree_vec (collapse);
1191   cond = make_tree_vec (collapse);
1192   incr = make_tree_vec (collapse);
1193
1194   if (pblock == NULL)
1195     {
1196       gfc_start_block (&block);
1197       pblock = &block;
1198     }
1199
1200   omp_clauses = gfc_trans_omp_clauses (pblock, do_clauses, code->loc);
1201
1202   for (i = 0; i < collapse; i++)
1203     {
1204       int simple = 0;
1205       int dovar_found = 0;
1206       tree dovar_decl;
1207
1208       if (clauses)
1209         {
1210           gfc_namelist *n;
1211           for (n = clauses->lists[OMP_LIST_LASTPRIVATE]; n != NULL;
1212                n = n->next)
1213             if (code->ext.iterator->var->symtree->n.sym == n->sym)
1214               break;
1215           if (n != NULL)
1216             dovar_found = 1;
1217           else if (n == NULL)
1218             for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next)
1219               if (code->ext.iterator->var->symtree->n.sym == n->sym)
1220                 break;
1221           if (n != NULL)
1222             dovar_found++;
1223         }
1224
1225       /* Evaluate all the expressions in the iterator.  */
1226       gfc_init_se (&se, NULL);
1227       gfc_conv_expr_lhs (&se, code->ext.iterator->var);
1228       gfc_add_block_to_block (pblock, &se.pre);
1229       dovar = se.expr;
1230       type = TREE_TYPE (dovar);
1231       gcc_assert (TREE_CODE (type) == INTEGER_TYPE);
1232
1233       gfc_init_se (&se, NULL);
1234       gfc_conv_expr_val (&se, code->ext.iterator->start);
1235       gfc_add_block_to_block (pblock, &se.pre);
1236       from = gfc_evaluate_now (se.expr, pblock);
1237
1238       gfc_init_se (&se, NULL);
1239       gfc_conv_expr_val (&se, code->ext.iterator->end);
1240       gfc_add_block_to_block (pblock, &se.pre);
1241       to = gfc_evaluate_now (se.expr, pblock);
1242
1243       gfc_init_se (&se, NULL);
1244       gfc_conv_expr_val (&se, code->ext.iterator->step);
1245       gfc_add_block_to_block (pblock, &se.pre);
1246       step = gfc_evaluate_now (se.expr, pblock);
1247       dovar_decl = dovar;
1248
1249       /* Special case simple loops.  */
1250       if (TREE_CODE (dovar) == VAR_DECL)
1251         {
1252           if (integer_onep (step))
1253             simple = 1;
1254           else if (tree_int_cst_equal (step, integer_minus_one_node))
1255             simple = -1;
1256         }
1257       else
1258         dovar_decl
1259           = gfc_trans_omp_variable (code->ext.iterator->var->symtree->n.sym);
1260
1261       /* Loop body.  */
1262       if (simple)
1263         {
1264           TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, dovar, from);
1265           TREE_VEC_ELT (cond, i) = fold_build2_loc (input_location, simple > 0
1266                                                     ? LE_EXPR : GE_EXPR,
1267                                                     boolean_type_node, dovar,
1268                                                     to);
1269           TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR,
1270                                                     type, dovar, step);
1271           TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location,
1272                                                     MODIFY_EXPR,
1273                                                     type, dovar,
1274                                                     TREE_VEC_ELT (incr, i));
1275         }
1276       else
1277         {
1278           /* STEP is not 1 or -1.  Use:
1279              for (count = 0; count < (to + step - from) / step; count++)
1280                {
1281                  dovar = from + count * step;
1282                  body;
1283                cycle_label:;
1284                }  */
1285           tmp = fold_build2_loc (input_location, MINUS_EXPR, type, step, from);
1286           tmp = fold_build2_loc (input_location, PLUS_EXPR, type, to, tmp);
1287           tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, type, tmp,
1288                                  step);
1289           tmp = gfc_evaluate_now (tmp, pblock);
1290           count = gfc_create_var (type, "count");
1291           TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, count,
1292                                              build_int_cst (type, 0));
1293           TREE_VEC_ELT (cond, i) = fold_build2_loc (input_location, LT_EXPR,
1294                                                     boolean_type_node,
1295                                                     count, tmp);
1296           TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR,
1297                                                     type, count,
1298                                                     build_int_cst (type, 1));
1299           TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location,
1300                                                     MODIFY_EXPR, type, count,
1301                                                     TREE_VEC_ELT (incr, i));
1302
1303           /* Initialize DOVAR.  */
1304           tmp = fold_build2_loc (input_location, MULT_EXPR, type, count, step);
1305           tmp = fold_build2_loc (input_location, PLUS_EXPR, type, from, tmp);
1306           di = VEC_safe_push (dovar_init, heap, inits, NULL);
1307           di->var = dovar;
1308           di->init = tmp;
1309         }
1310
1311       if (!dovar_found)
1312         {
1313           tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
1314           OMP_CLAUSE_DECL (tmp) = dovar_decl;
1315           omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
1316         }
1317       else if (dovar_found == 2)
1318         {
1319           tree c = NULL;
1320
1321           tmp = NULL;
1322           if (!simple)
1323             {
1324               /* If dovar is lastprivate, but different counter is used,
1325                  dovar += step needs to be added to
1326                  OMP_CLAUSE_LASTPRIVATE_STMT, otherwise the copied dovar
1327                  will have the value on entry of the last loop, rather
1328                  than value after iterator increment.  */
1329               tmp = gfc_evaluate_now (step, pblock);
1330               tmp = fold_build2_loc (input_location, PLUS_EXPR, type, dovar,
1331                                      tmp);
1332               tmp = fold_build2_loc (input_location, MODIFY_EXPR, type,
1333                                      dovar, tmp);
1334               for (c = omp_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
1335                 if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
1336                     && OMP_CLAUSE_DECL (c) == dovar_decl)
1337                   {
1338                     OMP_CLAUSE_LASTPRIVATE_STMT (c) = tmp;
1339                     break;
1340                   }
1341             }
1342           if (c == NULL && par_clauses != NULL)
1343             {
1344               for (c = par_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
1345                 if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
1346                     && OMP_CLAUSE_DECL (c) == dovar_decl)
1347                   {
1348                     tree l = build_omp_clause (input_location,
1349                                                OMP_CLAUSE_LASTPRIVATE);
1350                     OMP_CLAUSE_DECL (l) = dovar_decl;
1351                     OMP_CLAUSE_CHAIN (l) = omp_clauses;
1352                     OMP_CLAUSE_LASTPRIVATE_STMT (l) = tmp;
1353                     omp_clauses = l;
1354                     OMP_CLAUSE_SET_CODE (c, OMP_CLAUSE_SHARED);
1355                     break;
1356                   }
1357             }
1358           gcc_assert (simple || c != NULL);
1359         }
1360       if (!simple)
1361         {
1362           tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
1363           OMP_CLAUSE_DECL (tmp) = count;
1364           omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
1365         }
1366
1367       if (i + 1 < collapse)
1368         code = code->block->next;
1369     }
1370
1371   if (pblock != &block)
1372     {
1373       pushlevel (0);
1374       gfc_start_block (&block);
1375     }
1376
1377   gfc_start_block (&body);
1378
1379   FOR_EACH_VEC_ELT (dovar_init, inits, ix, di)
1380     gfc_add_modify (&body, di->var, di->init);
1381   VEC_free (dovar_init, heap, inits);
1382
1383   /* Cycle statement is implemented with a goto.  Exit statement must not be
1384      present for this loop.  */
1385   cycle_label = gfc_build_label_decl (NULL_TREE);
1386
1387   /* Put these labels where they can be found later.  */
1388
1389   code->cycle_label = cycle_label;
1390   code->exit_label = NULL_TREE;
1391
1392   /* Main loop body.  */
1393   tmp = gfc_trans_omp_code (code->block->next, true);
1394   gfc_add_expr_to_block (&body, tmp);
1395
1396   /* Label for cycle statements (if needed).  */
1397   if (TREE_USED (cycle_label))
1398     {
1399       tmp = build1_v (LABEL_EXPR, cycle_label);
1400       gfc_add_expr_to_block (&body, tmp);
1401     }
1402
1403   /* End of loop body.  */
1404   stmt = make_node (OMP_FOR);
1405
1406   TREE_TYPE (stmt) = void_type_node;
1407   OMP_FOR_BODY (stmt) = gfc_finish_block (&body);
1408   OMP_FOR_CLAUSES (stmt) = omp_clauses;
1409   OMP_FOR_INIT (stmt) = init;
1410   OMP_FOR_COND (stmt) = cond;
1411   OMP_FOR_INCR (stmt) = incr;
1412   gfc_add_expr_to_block (&block, stmt);
1413
1414   return gfc_finish_block (&block);
1415 }
1416
1417 static tree
1418 gfc_trans_omp_flush (void)
1419 {
1420   tree decl = built_in_decls [BUILT_IN_SYNCHRONIZE];
1421   return build_call_expr_loc (input_location, decl, 0);
1422 }
1423
1424 static tree
1425 gfc_trans_omp_master (gfc_code *code)
1426 {
1427   tree stmt = gfc_trans_code (code->block->next);
1428   if (IS_EMPTY_STMT (stmt))
1429     return stmt;
1430   return build1_v (OMP_MASTER, stmt);
1431 }
1432
1433 static tree
1434 gfc_trans_omp_ordered (gfc_code *code)
1435 {
1436   return build1_v (OMP_ORDERED, gfc_trans_code (code->block->next));
1437 }
1438
1439 static tree
1440 gfc_trans_omp_parallel (gfc_code *code)
1441 {
1442   stmtblock_t block;
1443   tree stmt, omp_clauses;
1444
1445   gfc_start_block (&block);
1446   omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
1447                                        code->loc);
1448   stmt = gfc_trans_omp_code (code->block->next, true);
1449   stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses);
1450   gfc_add_expr_to_block (&block, stmt);
1451   return gfc_finish_block (&block);
1452 }
1453
1454 static tree
1455 gfc_trans_omp_parallel_do (gfc_code *code)
1456 {
1457   stmtblock_t block, *pblock = NULL;
1458   gfc_omp_clauses parallel_clauses, do_clauses;
1459   tree stmt, omp_clauses = NULL_TREE;
1460
1461   gfc_start_block (&block);
1462
1463   memset (&do_clauses, 0, sizeof (do_clauses));
1464   if (code->ext.omp_clauses != NULL)
1465     {
1466       memcpy (&parallel_clauses, code->ext.omp_clauses,
1467               sizeof (parallel_clauses));
1468       do_clauses.sched_kind = parallel_clauses.sched_kind;
1469       do_clauses.chunk_size = parallel_clauses.chunk_size;
1470       do_clauses.ordered = parallel_clauses.ordered;
1471       do_clauses.collapse = parallel_clauses.collapse;
1472       parallel_clauses.sched_kind = OMP_SCHED_NONE;
1473       parallel_clauses.chunk_size = NULL;
1474       parallel_clauses.ordered = false;
1475       parallel_clauses.collapse = 0;
1476       omp_clauses = gfc_trans_omp_clauses (&block, &parallel_clauses,
1477                                            code->loc);
1478     }
1479   do_clauses.nowait = true;
1480   if (!do_clauses.ordered && do_clauses.sched_kind != OMP_SCHED_STATIC)
1481     pblock = &block;
1482   else
1483     pushlevel (0);
1484   stmt = gfc_trans_omp_do (code, pblock, &do_clauses, omp_clauses);
1485   if (TREE_CODE (stmt) != BIND_EXPR)
1486     stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
1487   else
1488     poplevel (0, 0, 0);
1489   stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses);
1490   OMP_PARALLEL_COMBINED (stmt) = 1;
1491   gfc_add_expr_to_block (&block, stmt);
1492   return gfc_finish_block (&block);
1493 }
1494
1495 static tree
1496 gfc_trans_omp_parallel_sections (gfc_code *code)
1497 {
1498   stmtblock_t block;
1499   gfc_omp_clauses section_clauses;
1500   tree stmt, omp_clauses;
1501
1502   memset (&section_clauses, 0, sizeof (section_clauses));
1503   section_clauses.nowait = true;
1504
1505   gfc_start_block (&block);
1506   omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
1507                                        code->loc);
1508   pushlevel (0);
1509   stmt = gfc_trans_omp_sections (code, &section_clauses);
1510   if (TREE_CODE (stmt) != BIND_EXPR)
1511     stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
1512   else
1513     poplevel (0, 0, 0);
1514   stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses);
1515   OMP_PARALLEL_COMBINED (stmt) = 1;
1516   gfc_add_expr_to_block (&block, stmt);
1517   return gfc_finish_block (&block);
1518 }
1519
1520 static tree
1521 gfc_trans_omp_parallel_workshare (gfc_code *code)
1522 {
1523   stmtblock_t block;
1524   gfc_omp_clauses workshare_clauses;
1525   tree stmt, omp_clauses;
1526
1527   memset (&workshare_clauses, 0, sizeof (workshare_clauses));
1528   workshare_clauses.nowait = true;
1529
1530   gfc_start_block (&block);
1531   omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
1532                                        code->loc);
1533   pushlevel (0);
1534   stmt = gfc_trans_omp_workshare (code, &workshare_clauses);
1535   if (TREE_CODE (stmt) != BIND_EXPR)
1536     stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
1537   else
1538     poplevel (0, 0, 0);
1539   stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses);
1540   OMP_PARALLEL_COMBINED (stmt) = 1;
1541   gfc_add_expr_to_block (&block, stmt);
1542   return gfc_finish_block (&block);
1543 }
1544
1545 static tree
1546 gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses)
1547 {
1548   stmtblock_t block, body;
1549   tree omp_clauses, stmt;
1550   bool has_lastprivate = clauses->lists[OMP_LIST_LASTPRIVATE] != NULL;
1551
1552   gfc_start_block (&block);
1553
1554   omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
1555
1556   gfc_init_block (&body);
1557   for (code = code->block; code; code = code->block)
1558     {
1559       /* Last section is special because of lastprivate, so even if it
1560          is empty, chain it in.  */
1561       stmt = gfc_trans_omp_code (code->next,
1562                                  has_lastprivate && code->block == NULL);
1563       if (! IS_EMPTY_STMT (stmt))
1564         {
1565           stmt = build1_v (OMP_SECTION, stmt);
1566           gfc_add_expr_to_block (&body, stmt);
1567         }
1568     }
1569   stmt = gfc_finish_block (&body);
1570
1571   stmt = build2 (OMP_SECTIONS, void_type_node, stmt, omp_clauses);
1572   gfc_add_expr_to_block (&block, stmt);
1573
1574   return gfc_finish_block (&block);
1575 }
1576
1577 static tree
1578 gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses)
1579 {
1580   tree omp_clauses = gfc_trans_omp_clauses (NULL, clauses, code->loc);
1581   tree stmt = gfc_trans_omp_code (code->block->next, true);
1582   stmt = build2 (OMP_SINGLE, void_type_node, stmt, omp_clauses);
1583   return stmt;
1584 }
1585
1586 static tree
1587 gfc_trans_omp_task (gfc_code *code)
1588 {
1589   stmtblock_t block;
1590   tree stmt, omp_clauses;
1591
1592   gfc_start_block (&block);
1593   omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
1594                                        code->loc);
1595   stmt = gfc_trans_omp_code (code->block->next, true);
1596   stmt = build2 (OMP_TASK, void_type_node, stmt, omp_clauses);
1597   gfc_add_expr_to_block (&block, stmt);
1598   return gfc_finish_block (&block);
1599 }
1600
1601 static tree
1602 gfc_trans_omp_taskwait (void)
1603 {
1604   tree decl = built_in_decls [BUILT_IN_GOMP_TASKWAIT];
1605   return build_call_expr_loc (input_location, decl, 0);
1606 }
1607
1608 static tree
1609 gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
1610 {
1611   tree res, tmp, stmt;
1612   stmtblock_t block, *pblock = NULL;
1613   stmtblock_t singleblock;
1614   int saved_ompws_flags;
1615   bool singleblock_in_progress = false;
1616   /* True if previous gfc_code in workshare construct is not workshared.  */
1617   bool prev_singleunit;
1618
1619   code = code->block->next;
1620
1621   pushlevel (0);
1622
1623   if (!code)
1624     return build_empty_stmt (input_location);
1625
1626   gfc_start_block (&block);
1627   pblock = &block;
1628
1629   ompws_flags = OMPWS_WORKSHARE_FLAG;
1630   prev_singleunit = false;
1631
1632   /* Translate statements one by one to trees until we reach
1633      the end of the workshare construct.  Adjacent gfc_codes that
1634      are a single unit of work are clustered and encapsulated in a
1635      single OMP_SINGLE construct.  */
1636   for (; code; code = code->next)
1637     {
1638       if (code->here != 0)
1639         {
1640           res = gfc_trans_label_here (code);
1641           gfc_add_expr_to_block (pblock, res);
1642         }
1643
1644       /* No dependence analysis, use for clauses with wait.
1645          If this is the last gfc_code, use default omp_clauses.  */
1646       if (code->next == NULL && clauses->nowait)
1647         ompws_flags |= OMPWS_NOWAIT;
1648
1649       /* By default, every gfc_code is a single unit of work.  */
1650       ompws_flags |= OMPWS_CURR_SINGLEUNIT;
1651       ompws_flags &= ~OMPWS_SCALARIZER_WS;
1652
1653       switch (code->op)
1654         {
1655         case EXEC_NOP:
1656           res = NULL_TREE;
1657           break;
1658
1659         case EXEC_ASSIGN:
1660           res = gfc_trans_assign (code);
1661           break;
1662
1663         case EXEC_POINTER_ASSIGN:
1664           res = gfc_trans_pointer_assign (code);
1665           break;
1666
1667         case EXEC_INIT_ASSIGN:
1668           res = gfc_trans_init_assign (code);
1669           break;
1670
1671         case EXEC_FORALL:
1672           res = gfc_trans_forall (code);
1673           break;
1674
1675         case EXEC_WHERE:
1676           res = gfc_trans_where (code);
1677           break;
1678
1679         case EXEC_OMP_ATOMIC:
1680           res = gfc_trans_omp_directive (code);
1681           break;
1682
1683         case EXEC_OMP_PARALLEL:
1684         case EXEC_OMP_PARALLEL_DO:
1685         case EXEC_OMP_PARALLEL_SECTIONS:
1686         case EXEC_OMP_PARALLEL_WORKSHARE:
1687         case EXEC_OMP_CRITICAL:
1688           saved_ompws_flags = ompws_flags;
1689           ompws_flags = 0;
1690           res = gfc_trans_omp_directive (code);
1691           ompws_flags = saved_ompws_flags;
1692           break;
1693
1694         default:
1695           internal_error ("gfc_trans_omp_workshare(): Bad statement code");
1696         }
1697
1698       gfc_set_backend_locus (&code->loc);
1699
1700       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
1701         {
1702           if (prev_singleunit)
1703             {
1704               if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
1705                 /* Add current gfc_code to single block.  */
1706                 gfc_add_expr_to_block (&singleblock, res);
1707               else
1708                 {
1709                   /* Finish single block and add it to pblock.  */
1710                   tmp = gfc_finish_block (&singleblock);
1711                   tmp = build2 (OMP_SINGLE, void_type_node, tmp, NULL_TREE);
1712                   gfc_add_expr_to_block (pblock, tmp);
1713                   /* Add current gfc_code to pblock.  */
1714                   gfc_add_expr_to_block (pblock, res);
1715                   singleblock_in_progress = false;
1716                 }
1717             }
1718           else
1719             {
1720               if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
1721                 {
1722                   /* Start single block.  */
1723                   gfc_init_block (&singleblock);
1724                   gfc_add_expr_to_block (&singleblock, res);
1725                   singleblock_in_progress = true;
1726                 }
1727               else
1728                 /* Add the new statement to the block.  */
1729                 gfc_add_expr_to_block (pblock, res);
1730             }
1731           prev_singleunit = (ompws_flags & OMPWS_CURR_SINGLEUNIT) != 0;
1732         }
1733     }
1734
1735   /* Finish remaining SINGLE block, if we were in the middle of one.  */
1736   if (singleblock_in_progress)
1737     {
1738       /* Finish single block and add it to pblock.  */
1739       tmp = gfc_finish_block (&singleblock);
1740       tmp = build2 (OMP_SINGLE, void_type_node, tmp,
1741                     clauses->nowait
1742                     ? build_omp_clause (input_location, OMP_CLAUSE_NOWAIT)
1743                     : NULL_TREE);
1744       gfc_add_expr_to_block (pblock, tmp);
1745     }
1746
1747   stmt = gfc_finish_block (pblock);
1748   if (TREE_CODE (stmt) != BIND_EXPR)
1749     {
1750       if (!IS_EMPTY_STMT (stmt))
1751         {
1752           tree bindblock = poplevel (1, 0, 0);
1753           stmt = build3_v (BIND_EXPR, NULL, stmt, bindblock);
1754         }
1755       else
1756         poplevel (0, 0, 0);
1757     }
1758   else
1759     poplevel (0, 0, 0);
1760
1761   ompws_flags = 0;
1762   return stmt;
1763 }
1764
1765 tree
1766 gfc_trans_omp_directive (gfc_code *code)
1767 {
1768   switch (code->op)
1769     {
1770     case EXEC_OMP_ATOMIC:
1771       return gfc_trans_omp_atomic (code);
1772     case EXEC_OMP_BARRIER:
1773       return gfc_trans_omp_barrier ();
1774     case EXEC_OMP_CRITICAL:
1775       return gfc_trans_omp_critical (code);
1776     case EXEC_OMP_DO:
1777       return gfc_trans_omp_do (code, NULL, code->ext.omp_clauses, NULL);
1778     case EXEC_OMP_FLUSH:
1779       return gfc_trans_omp_flush ();
1780     case EXEC_OMP_MASTER:
1781       return gfc_trans_omp_master (code);
1782     case EXEC_OMP_ORDERED:
1783       return gfc_trans_omp_ordered (code);
1784     case EXEC_OMP_PARALLEL:
1785       return gfc_trans_omp_parallel (code);
1786     case EXEC_OMP_PARALLEL_DO:
1787       return gfc_trans_omp_parallel_do (code);
1788     case EXEC_OMP_PARALLEL_SECTIONS:
1789       return gfc_trans_omp_parallel_sections (code);
1790     case EXEC_OMP_PARALLEL_WORKSHARE:
1791       return gfc_trans_omp_parallel_workshare (code);
1792     case EXEC_OMP_SECTIONS:
1793       return gfc_trans_omp_sections (code, code->ext.omp_clauses);
1794     case EXEC_OMP_SINGLE:
1795       return gfc_trans_omp_single (code, code->ext.omp_clauses);
1796     case EXEC_OMP_TASK:
1797       return gfc_trans_omp_task (code);
1798     case EXEC_OMP_TASKWAIT:
1799       return gfc_trans_omp_taskwait ();
1800     case EXEC_OMP_WORKSHARE:
1801       return gfc_trans_omp_workshare (code, code->ext.omp_clauses);
1802     default:
1803       gcc_unreachable ();
1804     }
1805 }