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_loc (input_location, COND_EXPR,
 206                          void_type_node, 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_loc (input_location, 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_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
1450                      omp_clauses);
1451   gfc_add_expr_to_block (&block, stmt);
1452   return gfc_finish_block (&block);
1453 }
1454
1455 static tree
1456 gfc_trans_omp_parallel_do (gfc_code *code)
1457 {
1458   stmtblock_t block, *pblock = NULL;
1459   gfc_omp_clauses parallel_clauses, do_clauses;
1460   tree stmt, omp_clauses = NULL_TREE;
1461
1462   gfc_start_block (&block);
1463
1464   memset (&do_clauses, 0, sizeof (do_clauses));
1465   if (code->ext.omp_clauses != NULL)
1466     {
1467       memcpy (&parallel_clauses, code->ext.omp_clauses,
1468               sizeof (parallel_clauses));
1469       do_clauses.sched_kind = parallel_clauses.sched_kind;
1470       do_clauses.chunk_size = parallel_clauses.chunk_size;
1471       do_clauses.ordered = parallel_clauses.ordered;
1472       do_clauses.collapse = parallel_clauses.collapse;
1473       parallel_clauses.sched_kind = OMP_SCHED_NONE;
1474       parallel_clauses.chunk_size = NULL;
1475       parallel_clauses.ordered = false;
1476       parallel_clauses.collapse = 0;
1477       omp_clauses = gfc_trans_omp_clauses (&block, &parallel_clauses,
1478                                            code->loc);
1479     }
1480   do_clauses.nowait = true;
1481   if (!do_clauses.ordered && do_clauses.sched_kind != OMP_SCHED_STATIC)
1482     pblock = &block;
1483   else
1484     pushlevel (0);
1485   stmt = gfc_trans_omp_do (code, pblock, &do_clauses, omp_clauses);
1486   if (TREE_CODE (stmt) != BIND_EXPR)
1487     stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
1488   else
1489     poplevel (0, 0, 0);
1490   stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
1491                      omp_clauses);
1492   OMP_PARALLEL_COMBINED (stmt) = 1;
1493   gfc_add_expr_to_block (&block, stmt);
1494   return gfc_finish_block (&block);
1495 }
1496
1497 static tree
1498 gfc_trans_omp_parallel_sections (gfc_code *code)
1499 {
1500   stmtblock_t block;
1501   gfc_omp_clauses section_clauses;
1502   tree stmt, omp_clauses;
1503
1504   memset (&section_clauses, 0, sizeof (section_clauses));
1505   section_clauses.nowait = true;
1506
1507   gfc_start_block (&block);
1508   omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
1509                                        code->loc);
1510   pushlevel (0);
1511   stmt = gfc_trans_omp_sections (code, &section_clauses);
1512   if (TREE_CODE (stmt) != BIND_EXPR)
1513     stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
1514   else
1515     poplevel (0, 0, 0);
1516   stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
1517                      omp_clauses);
1518   OMP_PARALLEL_COMBINED (stmt) = 1;
1519   gfc_add_expr_to_block (&block, stmt);
1520   return gfc_finish_block (&block);
1521 }
1522
1523 static tree
1524 gfc_trans_omp_parallel_workshare (gfc_code *code)
1525 {
1526   stmtblock_t block;
1527   gfc_omp_clauses workshare_clauses;
1528   tree stmt, omp_clauses;
1529
1530   memset (&workshare_clauses, 0, sizeof (workshare_clauses));
1531   workshare_clauses.nowait = true;
1532
1533   gfc_start_block (&block);
1534   omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
1535                                        code->loc);
1536   pushlevel (0);
1537   stmt = gfc_trans_omp_workshare (code, &workshare_clauses);
1538   if (TREE_CODE (stmt) != BIND_EXPR)
1539     stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
1540   else
1541     poplevel (0, 0, 0);
1542   stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
1543                      omp_clauses);
1544   OMP_PARALLEL_COMBINED (stmt) = 1;
1545   gfc_add_expr_to_block (&block, stmt);
1546   return gfc_finish_block (&block);
1547 }
1548
1549 static tree
1550 gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses)
1551 {
1552   stmtblock_t block, body;
1553   tree omp_clauses, stmt;
1554   bool has_lastprivate = clauses->lists[OMP_LIST_LASTPRIVATE] != NULL;
1555
1556   gfc_start_block (&block);
1557
1558   omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
1559
1560   gfc_init_block (&body);
1561   for (code = code->block; code; code = code->block)
1562     {
1563       /* Last section is special because of lastprivate, so even if it
1564          is empty, chain it in.  */
1565       stmt = gfc_trans_omp_code (code->next,
1566                                  has_lastprivate && code->block == NULL);
1567       if (! IS_EMPTY_STMT (stmt))
1568         {
1569           stmt = build1_v (OMP_SECTION, stmt);
1570           gfc_add_expr_to_block (&body, stmt);
1571         }
1572     }
1573   stmt = gfc_finish_block (&body);
1574
1575   stmt = build2_loc (input_location, OMP_SECTIONS, void_type_node, stmt,
1576                      omp_clauses);
1577   gfc_add_expr_to_block (&block, stmt);
1578
1579   return gfc_finish_block (&block);
1580 }
1581
1582 static tree
1583 gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses)
1584 {
1585   tree omp_clauses = gfc_trans_omp_clauses (NULL, clauses, code->loc);
1586   tree stmt = gfc_trans_omp_code (code->block->next, true);
1587   stmt = build2_loc (input_location, OMP_SINGLE, void_type_node, stmt,
1588                      omp_clauses);
1589   return stmt;
1590 }
1591
1592 static tree
1593 gfc_trans_omp_task (gfc_code *code)
1594 {
1595   stmtblock_t block;
1596   tree stmt, omp_clauses;
1597
1598   gfc_start_block (&block);
1599   omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
1600                                        code->loc);
1601   stmt = gfc_trans_omp_code (code->block->next, true);
1602   stmt = build2_loc (input_location, OMP_TASK, void_type_node, stmt,
1603                      omp_clauses);
1604   gfc_add_expr_to_block (&block, stmt);
1605   return gfc_finish_block (&block);
1606 }
1607
1608 static tree
1609 gfc_trans_omp_taskwait (void)
1610 {
1611   tree decl = built_in_decls [BUILT_IN_GOMP_TASKWAIT];
1612   return build_call_expr_loc (input_location, decl, 0);
1613 }
1614
1615 static tree
1616 gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
1617 {
1618   tree res, tmp, stmt;
1619   stmtblock_t block, *pblock = NULL;
1620   stmtblock_t singleblock;
1621   int saved_ompws_flags;
1622   bool singleblock_in_progress = false;
1623   /* True if previous gfc_code in workshare construct is not workshared.  */
1624   bool prev_singleunit;
1625
1626   code = code->block->next;
1627
1628   pushlevel (0);
1629
1630   if (!code)
1631     return build_empty_stmt (input_location);
1632
1633   gfc_start_block (&block);
1634   pblock = &block;
1635
1636   ompws_flags = OMPWS_WORKSHARE_FLAG;
1637   prev_singleunit = false;
1638
1639   /* Translate statements one by one to trees until we reach
1640      the end of the workshare construct.  Adjacent gfc_codes that
1641      are a single unit of work are clustered and encapsulated in a
1642      single OMP_SINGLE construct.  */
1643   for (; code; code = code->next)
1644     {
1645       if (code->here != 0)
1646         {
1647           res = gfc_trans_label_here (code);
1648           gfc_add_expr_to_block (pblock, res);
1649         }
1650
1651       /* No dependence analysis, use for clauses with wait.
1652          If this is the last gfc_code, use default omp_clauses.  */
1653       if (code->next == NULL && clauses->nowait)
1654         ompws_flags |= OMPWS_NOWAIT;
1655
1656       /* By default, every gfc_code is a single unit of work.  */
1657       ompws_flags |= OMPWS_CURR_SINGLEUNIT;
1658       ompws_flags &= ~OMPWS_SCALARIZER_WS;
1659
1660       switch (code->op)
1661         {
1662         case EXEC_NOP:
1663           res = NULL_TREE;
1664           break;
1665
1666         case EXEC_ASSIGN:
1667           res = gfc_trans_assign (code);
1668           break;
1669
1670         case EXEC_POINTER_ASSIGN:
1671           res = gfc_trans_pointer_assign (code);
1672           break;
1673
1674         case EXEC_INIT_ASSIGN:
1675           res = gfc_trans_init_assign (code);
1676           break;
1677
1678         case EXEC_FORALL:
1679           res = gfc_trans_forall (code);
1680           break;
1681
1682         case EXEC_WHERE:
1683           res = gfc_trans_where (code);
1684           break;
1685
1686         case EXEC_OMP_ATOMIC:
1687           res = gfc_trans_omp_directive (code);
1688           break;
1689
1690         case EXEC_OMP_PARALLEL:
1691         case EXEC_OMP_PARALLEL_DO:
1692         case EXEC_OMP_PARALLEL_SECTIONS:
1693         case EXEC_OMP_PARALLEL_WORKSHARE:
1694         case EXEC_OMP_CRITICAL:
1695           saved_ompws_flags = ompws_flags;
1696           ompws_flags = 0;
1697           res = gfc_trans_omp_directive (code);
1698           ompws_flags = saved_ompws_flags;
1699           break;
1700
1701         default:
1702           internal_error ("gfc_trans_omp_workshare(): Bad statement code");
1703         }
1704
1705       gfc_set_backend_locus (&code->loc);
1706
1707       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
1708         {
1709           if (prev_singleunit)
1710             {
1711               if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
1712                 /* Add current gfc_code to single block.  */
1713                 gfc_add_expr_to_block (&singleblock, res);
1714               else
1715                 {
1716                   /* Finish single block and add it to pblock.  */
1717                   tmp = gfc_finish_block (&singleblock);
1718                   tmp = build2_loc (input_location, OMP_SINGLE,
1719                                     void_type_node, tmp, NULL_TREE);
1720                   gfc_add_expr_to_block (pblock, tmp);
1721                   /* Add current gfc_code to pblock.  */
1722                   gfc_add_expr_to_block (pblock, res);
1723                   singleblock_in_progress = false;
1724                 }
1725             }
1726           else
1727             {
1728               if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
1729                 {
1730                   /* Start single block.  */
1731                   gfc_init_block (&singleblock);
1732                   gfc_add_expr_to_block (&singleblock, res);
1733                   singleblock_in_progress = true;
1734                 }
1735               else
1736                 /* Add the new statement to the block.  */
1737                 gfc_add_expr_to_block (pblock, res);
1738             }
1739           prev_singleunit = (ompws_flags & OMPWS_CURR_SINGLEUNIT) != 0;
1740         }
1741     }
1742
1743   /* Finish remaining SINGLE block, if we were in the middle of one.  */
1744   if (singleblock_in_progress)
1745     {
1746       /* Finish single block and add it to pblock.  */
1747       tmp = gfc_finish_block (&singleblock);
1748       tmp = build2_loc (input_location, OMP_SINGLE, void_type_node, tmp,
1749                         clauses->nowait
1750                         ? build_omp_clause (input_location, OMP_CLAUSE_NOWAIT)
1751                         : NULL_TREE);
1752       gfc_add_expr_to_block (pblock, tmp);
1753     }
1754
1755   stmt = gfc_finish_block (pblock);
1756   if (TREE_CODE (stmt) != BIND_EXPR)
1757     {
1758       if (!IS_EMPTY_STMT (stmt))
1759         {
1760           tree bindblock = poplevel (1, 0, 0);
1761           stmt = build3_v (BIND_EXPR, NULL, stmt, bindblock);
1762         }
1763       else
1764         poplevel (0, 0, 0);
1765     }
1766   else
1767     poplevel (0, 0, 0);
1768
1769   ompws_flags = 0;
1770   return stmt;
1771 }
1772
1773 tree
1774 gfc_trans_omp_directive (gfc_code *code)
1775 {
1776   switch (code->op)
1777     {
1778     case EXEC_OMP_ATOMIC:
1779       return gfc_trans_omp_atomic (code);
1780     case EXEC_OMP_BARRIER:
1781       return gfc_trans_omp_barrier ();
1782     case EXEC_OMP_CRITICAL:
1783       return gfc_trans_omp_critical (code);
1784     case EXEC_OMP_DO:
1785       return gfc_trans_omp_do (code, NULL, code->ext.omp_clauses, NULL);
1786     case EXEC_OMP_FLUSH:
1787       return gfc_trans_omp_flush ();
1788     case EXEC_OMP_MASTER:
1789       return gfc_trans_omp_master (code);
1790     case EXEC_OMP_ORDERED:
1791       return gfc_trans_omp_ordered (code);
1792     case EXEC_OMP_PARALLEL:
1793       return gfc_trans_omp_parallel (code);
1794     case EXEC_OMP_PARALLEL_DO:
1795       return gfc_trans_omp_parallel_do (code);
1796     case EXEC_OMP_PARALLEL_SECTIONS:
1797       return gfc_trans_omp_parallel_sections (code);
1798     case EXEC_OMP_PARALLEL_WORKSHARE:
1799       return gfc_trans_omp_parallel_workshare (code);
1800     case EXEC_OMP_SECTIONS:
1801       return gfc_trans_omp_sections (code, code->ext.omp_clauses);
1802     case EXEC_OMP_SINGLE:
1803       return gfc_trans_omp_single (code, code->ext.omp_clauses);
1804     case EXEC_OMP_TASK:
1805       return gfc_trans_omp_task (code);
1806     case EXEC_OMP_TASKWAIT:
1807       return gfc_trans_omp_taskwait ();
1808     case EXEC_OMP_WORKSHARE:
1809       return gfc_trans_omp_workshare (code, code->ext.omp_clauses);
1810     default:
1811       gcc_unreachable ();
1812     }
1813 }