OSDN Git Service

2010-09-03 Tobias Burnus <burnus@net-b.de>
[pf3gnuchains/gcc-fork.git] / gcc / fortran / trans-openmp.c
index 6f99800..d1638b6 100644 (file)
@@ -1,5 +1,6 @@
 /* OpenMP directive translation -- generate GCC trees from gfc_code.
-   Copyright (C) 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+   Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010
+   Free Software Foundation, Inc.
    Contributed by Jakub Jelinek <jakub@redhat.com>
 
 This file is part of GCC.
@@ -23,10 +24,8 @@ along with GCC; see the file COPYING3.  If not see
 #include "system.h"
 #include "coretypes.h"
 #include "tree.h"
-#include "tree-gimple.h"
-#include "ggc.h"
-#include "toplev.h"
-#include "real.h"
+#include "gimple.h"    /* For create_tmp_var_raw.  */
+#include "diagnostic-core.h"   /* For internal_error.  */
 #include "gfortran.h"
 #include "trans.h"
 #include "trans-stmt.h"
@@ -35,6 +34,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "trans-const.h"
 #include "arith.h"
 
+int ompws_flags;
 
 /* True if OpenMP should privatize what this DECL points to rather
    than the DECL itself.  */
@@ -56,7 +56,8 @@ gfc_omp_privatize_by_reference (const_tree decl)
       if (GFC_POINTER_TYPE_P (type))
        return false;
 
-      if (!DECL_ARTIFICIAL (decl))
+      if (!DECL_ARTIFICIAL (decl)
+         && TREE_CODE (TREE_TYPE (type)) != FUNCTION_TYPE)
        return true;
 
       /* Some arrays are expanded as DECL_ARTIFICIAL pointers
@@ -74,7 +75,10 @@ gfc_omp_privatize_by_reference (const_tree decl)
 enum omp_clause_default_kind
 gfc_omp_predetermined_sharing (tree decl)
 {
-  if (DECL_ARTIFICIAL (decl) && ! GFC_DECL_RESULT (decl))
+  if (DECL_ARTIFICIAL (decl)
+      && ! GFC_DECL_RESULT (decl)
+      && ! (DECL_LANG_SPECIFIC (decl)
+           && GFC_DECL_SAVED_DESCRIPTOR (decl)))
     return OMP_CLAUSE_DEFAULT_SHARED;
 
   /* Cray pointees shouldn't be listed in any clauses and should be
@@ -95,6 +99,15 @@ gfc_omp_predetermined_sharing (tree decl)
         == NULL)
     return OMP_CLAUSE_DEFAULT_SHARED;
 
+  /* Dummy procedures aren't considered variables by OpenMP, thus are
+     disallowed in OpenMP clauses.  They are represented as PARM_DECLs
+     in the middle-end, so return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE here
+     to avoid complaining about their uses with default(none).  */
+  if (TREE_CODE (decl) == PARM_DECL
+      && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE
+      && TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) == FUNCTION_TYPE)
+    return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
+
   /* COMMON and EQUIVALENCE decls are shared.  They
      are only referenced through DECL_VALUE_EXPR of the variables
      contained in them.  If those are privatized, they will not be
@@ -108,6 +121,19 @@ gfc_omp_predetermined_sharing (tree decl)
   return OMP_CLAUSE_DEFAULT_UNSPECIFIED;
 }
 
+/* Return decl that should be used when reporting DEFAULT(NONE)
+   diagnostics.  */
+
+tree
+gfc_omp_report_decl (tree decl)
+{
+  if (DECL_ARTIFICIAL (decl)
+      && DECL_LANG_SPECIFIC (decl)
+      && GFC_DECL_SAVED_DESCRIPTOR (decl))
+    return GFC_DECL_SAVED_DESCRIPTOR (decl);
+
+  return decl;
+}
 
 /* Return true if DECL in private clause needs
    OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause.  */
@@ -147,34 +173,35 @@ gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer)
 
   gfc_init_block (&cond_block);
 
-  gfc_add_modify_expr (&cond_block, decl, outer);
+  gfc_add_modify (&cond_block, decl, outer);
   rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
-  size = gfc_conv_descriptor_ubound (decl, rank);
-  size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
-                     gfc_conv_descriptor_lbound (decl, rank));
-  size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
-                     gfc_index_one_node);
+  size = gfc_conv_descriptor_ubound_get (decl, rank);
+  size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+                         size, gfc_conv_descriptor_lbound_get (decl, rank));
+  size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+                         size, gfc_index_one_node);
   if (GFC_TYPE_ARRAY_RANK (type) > 1)
-    size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
-                       gfc_conv_descriptor_stride (decl, rank));
+    size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+                           size, gfc_conv_descriptor_stride_get (decl, rank));
   esize = fold_convert (gfc_array_index_type,
                        TYPE_SIZE_UNIT (gfc_get_element_type (type)));
-  size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize);
+  size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+                         size, esize);
   size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block);
   ptr = gfc_allocate_array_with_status (&cond_block,
                                        build_int_cst (pvoid_type_node, 0),
-                                       size, NULL);
-  gfc_conv_descriptor_data_set_tuples (&cond_block, decl, ptr);
+                                       size, NULL, NULL);
+  gfc_conv_descriptor_data_set (&cond_block, decl, ptr);
   then_b = gfc_finish_block (&cond_block);
 
   gfc_init_block (&cond_block);
-  gfc_conv_descriptor_data_set_tuples (&cond_block, decl, null_pointer_node);
+  gfc_conv_descriptor_data_set (&cond_block, decl, null_pointer_node);
   else_b = gfc_finish_block (&cond_block);
 
-  cond = fold_build2 (NE_EXPR, boolean_type_node,
-                     fold_convert (pvoid_type_node,
-                                   gfc_conv_descriptor_data_get (outer)),
-                     null_pointer_node);
+  cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+                         fold_convert (pvoid_type_node,
+                                       gfc_conv_descriptor_data_get (outer)),
+                         null_pointer_node);
   gfc_add_expr_to_block (&block, build3 (COND_EXPR, void_type_node,
                         cond, then_b, else_b));
 
@@ -191,7 +218,7 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
 
   if (! GFC_DESCRIPTOR_TYPE_P (type)
       || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
-    return build_gimple_modify_stmt (dest, src);
+    return build2_v (MODIFY_EXPR, dest, src);
 
   gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE);
 
@@ -199,25 +226,27 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
      and copied from SRC.  */
   gfc_start_block (&block);
 
-  gfc_add_modify_expr (&block, dest, src);
+  gfc_add_modify (&block, dest, src);
   rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
-  size = gfc_conv_descriptor_ubound (dest, rank);
-  size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
-                     gfc_conv_descriptor_lbound (dest, rank));
-  size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
-                     gfc_index_one_node);
+  size = gfc_conv_descriptor_ubound_get (dest, rank);
+  size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+                         size, gfc_conv_descriptor_lbound_get (dest, rank));
+  size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+                         size, gfc_index_one_node);
   if (GFC_TYPE_ARRAY_RANK (type) > 1)
-    size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
-                       gfc_conv_descriptor_stride (dest, rank));
+    size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+                           size, gfc_conv_descriptor_stride_get (dest, rank));
   esize = fold_convert (gfc_array_index_type,
                        TYPE_SIZE_UNIT (gfc_get_element_type (type)));
-  size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize);
+  size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+                         size, esize);
   size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
   ptr = gfc_allocate_array_with_status (&block,
                                        build_int_cst (pvoid_type_node, 0),
-                                       size, NULL);
-  gfc_conv_descriptor_data_set_tuples (&block, dest, ptr);
-  call = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, ptr,
+                                       size, NULL, NULL);
+  gfc_conv_descriptor_data_set (&block, dest, ptr);
+  call = build_call_expr_loc (input_location,
+                         built_in_decls[BUILT_IN_MEMCPY], 3, ptr,
                          fold_convert (pvoid_type_node,
                                        gfc_conv_descriptor_data_get (src)),
                          size);
@@ -236,25 +265,27 @@ gfc_omp_clause_assign_op (tree clause ATTRIBUTE_UNUSED, tree dest, tree src)
 
   if (! GFC_DESCRIPTOR_TYPE_P (type)
       || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
-    return build_gimple_modify_stmt (dest, src);
+    return build2_v (MODIFY_EXPR, dest, src);
 
   /* Handle copying allocatable arrays.  */
   gfc_start_block (&block);
 
   rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
-  size = gfc_conv_descriptor_ubound (dest, rank);
-  size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
-                     gfc_conv_descriptor_lbound (dest, rank));
-  size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
-                     gfc_index_one_node);
+  size = gfc_conv_descriptor_ubound_get (dest, rank);
+  size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+                         size, gfc_conv_descriptor_lbound_get (dest, rank));
+  size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+                         size, gfc_index_one_node);
   if (GFC_TYPE_ARRAY_RANK (type) > 1)
-    size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
-                       gfc_conv_descriptor_stride (dest, rank));
+    size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+                           size, gfc_conv_descriptor_stride_get (dest, rank));
   esize = fold_convert (gfc_array_index_type,
                        TYPE_SIZE_UNIT (gfc_get_element_type (type)));
-  size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize);
+  size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+                         size, esize);
   size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
-  call = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
+  call = build_call_expr_loc (input_location,
+                         built_in_decls[BUILT_IN_MEMCPY], 3,
                          fold_convert (pvoid_type_node,
                                        gfc_conv_descriptor_data_get (dest)),
                          fold_convert (pvoid_type_node,
@@ -435,7 +466,7 @@ gfc_trans_omp_variable_list (enum omp_clause_code code, gfc_namelist *namelist,
        tree t = gfc_trans_omp_variable (namelist->sym);
        if (t != error_mark_node)
          {
-           tree node = build_omp_clause (code);
+           tree node = build_omp_clause (input_location, code);
            OMP_CLAUSE_DECL (node) = t;
            list = gfc_trans_add_clause (node, list);
          }
@@ -454,7 +485,7 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
   tree decl, backend_decl, stmt;
   locus old_loc = gfc_current_locus;
   const char *iname;
-  try t;
+  gfc_try t;
 
   decl = OMP_CLAUSE_DECL (c);
   gfc_current_locus = where;
@@ -498,6 +529,7 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
   e1->symtree = symtree1;
   e1->ts = sym->ts;
   e1->ref = ref = gfc_get_ref ();
+  ref->type = REF_ARRAY;
   ref->u.ar.where = where;
   ref->u.ar.as = sym->as;
   ref->u.ar.type = AR_FULL;
@@ -602,29 +634,33 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
 
       gfc_start_block (&block);
 
-      gfc_add_modify_expr (&block, decl, outer_sym.backend_decl);
+      gfc_add_modify (&block, decl, outer_sym.backend_decl);
       rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
-      size = gfc_conv_descriptor_ubound (decl, rank);
-      size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
-                         gfc_conv_descriptor_lbound (decl, rank));
-      size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
-                         gfc_index_one_node);
+      size = gfc_conv_descriptor_ubound_get (decl, rank);
+      size = fold_build2_loc (input_location, MINUS_EXPR,
+                             gfc_array_index_type, size,
+                             gfc_conv_descriptor_lbound_get (decl, rank));
+      size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+                             size, gfc_index_one_node);
       if (GFC_TYPE_ARRAY_RANK (type) > 1)
-       size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
-                           gfc_conv_descriptor_stride (decl, rank));
+       size = fold_build2_loc (input_location, MULT_EXPR,
+                               gfc_array_index_type, size,
+                               gfc_conv_descriptor_stride_get (decl, rank));
       esize = fold_convert (gfc_array_index_type,
                            TYPE_SIZE_UNIT (gfc_get_element_type (type)));
-      size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize);
+      size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+                             size, esize);
       size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
       ptr = gfc_allocate_array_with_status (&block,
                                            build_int_cst (pvoid_type_node, 0),
-                                           size, NULL);
-      gfc_conv_descriptor_data_set_tuples (&block, decl, ptr);
-      gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false));
+                                           size, NULL, NULL);
+      gfc_conv_descriptor_data_set (&block, decl, ptr);
+      gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false,
+                            false));
       stmt = gfc_finish_block (&block);
     }
   else
-    stmt = gfc_trans_assignment (e1, e2, false);
+    stmt = gfc_trans_assignment (e1, e2, false, false);
   if (TREE_CODE (stmt) != BIND_EXPR)
     stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
   else
@@ -641,12 +677,13 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
       stmtblock_t block;
 
       gfc_start_block (&block);
-      gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false));
+      gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false,
+                            true));
       gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl));
       stmt = gfc_finish_block (&block);
     }
   else
-    stmt = gfc_trans_assignment (e3, e4, false);
+    stmt = gfc_trans_assignment (e3, e4, false, true);
   if (TREE_CODE (stmt) != BIND_EXPR)
     stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
   else
@@ -680,7 +717,8 @@ gfc_trans_omp_reduction_list (gfc_namelist *namelist, tree list,
        tree t = gfc_trans_omp_variable (namelist->sym);
        if (t != error_mark_node)
          {
-           tree node = build_omp_clause (OMP_CLAUSE_REDUCTION);
+           tree node = build_omp_clause (where.lb->location,
+                                         OMP_CLAUSE_REDUCTION);
            OMP_CLAUSE_DECL (node) = t;
            OMP_CLAUSE_REDUCTION_CODE (node) = reduction_code;
            if (namelist->sym->attr.dimension)
@@ -695,7 +733,7 @@ static tree
 gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
                       locus where)
 {
-  tree omp_clauses = NULL_TREE, chunk_size, c, old_clauses;
+  tree omp_clauses = NULL_TREE, chunk_size, c;
   int list;
   enum omp_clause_code clause_code;
   gfc_se se;
@@ -754,7 +792,6 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
            default:
              gcc_unreachable ();
            }
-         old_clauses = omp_clauses;
          omp_clauses
            = gfc_trans_omp_reduction_list (n, omp_clauses, reduction_code,
                                            where);
@@ -799,7 +836,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
       if_var = gfc_evaluate_now (se.expr, block);
       gfc_add_block_to_block (block, &se.post);
 
-      c = build_omp_clause (OMP_CLAUSE_IF);
+      c = build_omp_clause (where.lb->location, OMP_CLAUSE_IF);
       OMP_CLAUSE_IF_EXPR (c) = if_var;
       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
     }
@@ -814,7 +851,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
       num_threads = gfc_evaluate_now (se.expr, block);
       gfc_add_block_to_block (block, &se.post);
 
-      c = build_omp_clause (OMP_CLAUSE_NUM_THREADS);
+      c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_THREADS);
       OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads;
       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
     }
@@ -831,7 +868,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
 
   if (clauses->sched_kind != OMP_SCHED_NONE)
     {
-      c = build_omp_clause (OMP_CLAUSE_SCHEDULE);
+      c = build_omp_clause (where.lb->location, OMP_CLAUSE_SCHEDULE);
       OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
       switch (clauses->sched_kind)
        {
@@ -858,7 +895,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
 
   if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
     {
-      c = build_omp_clause (OMP_CLAUSE_DEFAULT);
+      c = build_omp_clause (where.lb->location, OMP_CLAUSE_DEFAULT);
       switch (clauses->default_sharing)
        {
        case OMP_DEFAULT_NONE:
@@ -881,25 +918,25 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
 
   if (clauses->nowait)
     {
-      c = build_omp_clause (OMP_CLAUSE_NOWAIT);
+      c = build_omp_clause (where.lb->location, OMP_CLAUSE_NOWAIT);
       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
     }
 
   if (clauses->ordered)
     {
-      c = build_omp_clause (OMP_CLAUSE_ORDERED);
+      c = build_omp_clause (where.lb->location, OMP_CLAUSE_ORDERED);
       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
     }
 
   if (clauses->untied)
     {
-      c = build_omp_clause (OMP_CLAUSE_UNTIED);
+      c = build_omp_clause (where.lb->location, OMP_CLAUSE_UNTIED);
       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
     }
 
   if (clauses->collapse)
     {
-      c = build_omp_clause (OMP_CLAUSE_COLLAPSE);
+      c = build_omp_clause (where.lb->location, OMP_CLAUSE_COLLAPSE);
       OMP_CLAUSE_COLLAPSE_EXPR (c) = build_int_cst (NULL, clauses->collapse);
       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
     }
@@ -950,13 +987,13 @@ gfc_trans_omp_atomic (gfc_code *code)
   code = code->block->next;
   gcc_assert (code->op == EXEC_ASSIGN);
   gcc_assert (code->next == NULL);
-  var = code->expr->symtree->n.sym;
+  var = code->expr1->symtree->n.sym;
 
   gfc_init_se (&lse, NULL);
   gfc_init_se (&rse, NULL);
   gfc_start_block (&block);
 
-  gfc_conv_expr (&lse, code->expr);
+  gfc_conv_expr (&lse, code->expr1);
   gfc_add_block_to_block (&block, &lse.pre);
   type = TREE_TYPE (lse.expr);
   lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
@@ -969,7 +1006,7 @@ gfc_trans_omp_atomic (gfc_code *code)
   if (expr2->expr_type == EXPR_OP)
     {
       gfc_expr *e;
-      switch (expr2->value.op.operator)
+      switch (expr2->value.op.op)
        {
        case INTRINSIC_PLUS:
          op = PLUS_EXPR;
@@ -1062,15 +1099,16 @@ gfc_trans_omp_atomic (gfc_code *code)
          tree accum = gfc_create_var (TREE_TYPE (rse.expr), NULL);
          gfc_actual_arglist *arg;
 
-         gfc_add_modify_stmt (&block, accum, rse.expr);
+         gfc_add_modify (&block, accum, rse.expr);
          for (arg = expr2->value.function.actual->next->next; arg;
               arg = arg->next)
            {
              gfc_init_block (&rse.pre);
              gfc_conv_expr (&rse, arg->expr);
              gfc_add_block_to_block (&block, &rse.pre);
-             x = fold_build2 (op, TREE_TYPE (accum), accum, rse.expr);
-             gfc_add_modify_stmt (&block, accum, x);
+             x = fold_build2_loc (input_location, op, TREE_TYPE (accum),
+                                  accum, rse.expr);
+             gfc_add_modify (&block, accum, x);
            }
 
          rse.expr = accum;
@@ -1081,16 +1119,18 @@ gfc_trans_omp_atomic (gfc_code *code)
 
   lhsaddr = save_expr (lhsaddr);
   rhs = gfc_evaluate_now (rse.expr, &block);
-  x = convert (TREE_TYPE (rhs), build_fold_indirect_ref (lhsaddr));
+  x = convert (TREE_TYPE (rhs), build_fold_indirect_ref_loc (input_location,
+                                                        lhsaddr));
 
   if (var_on_left)
-    x = fold_build2 (op, TREE_TYPE (rhs), x, rhs);
+    x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), x, rhs);
   else
-    x = fold_build2 (op, TREE_TYPE (rhs), rhs, x);
+    x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), rhs, x);
 
   if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE
       && TREE_CODE (type) != COMPLEX_TYPE)
-    x = fold_build1 (REALPART_EXPR, TREE_TYPE (TREE_TYPE (rhs)), x);
+    x = fold_build1_loc (input_location, REALPART_EXPR,
+                        TREE_TYPE (TREE_TYPE (rhs)), x);
 
   x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x));
   gfc_add_expr_to_block (&block, x);
@@ -1105,7 +1145,7 @@ static tree
 gfc_trans_omp_barrier (void)
 {
   tree decl = built_in_decls [BUILT_IN_GOMP_BARRIER];
-  return build_call_expr (decl, 0);
+  return build_call_expr_loc (input_location, decl, 0);
 }
 
 static tree
@@ -1118,6 +1158,14 @@ gfc_trans_omp_critical (gfc_code *code)
   return build2 (OMP_CRITICAL, void_type_node, stmt, name);
 }
 
+typedef struct dovar_init_d {
+  tree var;
+  tree init;
+} dovar_init;
+
+DEF_VEC_O(dovar_init);
+DEF_VEC_ALLOC_O(dovar_init,heap);
+
 static tree
 gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock,
                  gfc_omp_clauses *do_clauses, tree par_clauses)
@@ -1128,14 +1176,15 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock,
   stmtblock_t block;
   stmtblock_t body;
   gfc_omp_clauses *clauses = code->ext.omp_clauses;
-  gfc_code *outermost;
   int i, collapse = clauses->collapse;
-  tree dovar_init = NULL_TREE;
+  VEC(dovar_init,heap) *inits = NULL;
+  dovar_init *di;
+  unsigned ix;
 
   if (collapse <= 0)
     collapse = 1;
 
-  outermost = code = code->block->next;
+  code = code->block->next;
   gcc_assert (code->op == EXEC_DO);
 
   init = make_tree_vec (collapse);
@@ -1154,6 +1203,7 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock,
     {
       int simple = 0;
       int dovar_found = 0;
+      tree dovar_decl;
 
       if (clauses)
        {
@@ -1194,22 +1244,34 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock,
       gfc_conv_expr_val (&se, code->ext.iterator->step);
       gfc_add_block_to_block (pblock, &se.pre);
       step = gfc_evaluate_now (se.expr, pblock);
+      dovar_decl = dovar;
 
       /* Special case simple loops.  */
-      if (integer_onep (step))
-       simple = 1;
-      else if (tree_int_cst_equal (step, integer_minus_one_node))
-       simple = -1;
+      if (TREE_CODE (dovar) == VAR_DECL)
+       {
+         if (integer_onep (step))
+           simple = 1;
+         else if (tree_int_cst_equal (step, integer_minus_one_node))
+           simple = -1;
+       }
+      else
+       dovar_decl
+         = gfc_trans_omp_variable (code->ext.iterator->var->symtree->n.sym);
 
       /* Loop body.  */
       if (simple)
        {
-         TREE_VEC_ELT (init, i) = build2_v (GIMPLE_MODIFY_STMT, dovar, from);
-         TREE_VEC_ELT (cond, i) = fold_build2 (simple > 0 ? LE_EXPR : GE_EXPR,
-                                               boolean_type_node, dovar, to);
-         TREE_VEC_ELT (incr, i) = fold_build2 (PLUS_EXPR, type, dovar, step);
-         TREE_VEC_ELT (incr, i) = fold_build2 (GIMPLE_MODIFY_STMT, type, dovar,
-                                               TREE_VEC_ELT (incr, i));
+         TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, dovar, from);
+         TREE_VEC_ELT (cond, i) = fold_build2_loc (input_location, simple > 0
+                                                   ? LE_EXPR : GE_EXPR,
+                                                   boolean_type_node, dovar,
+                                                   to);
+         TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR,
+                                                   type, dovar, step);
+         TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location,
+                                                   MODIFY_EXPR,
+                                                   type, dovar,
+                                                   TREE_VEC_ELT (incr, i));
        }
       else
        {
@@ -1220,30 +1282,36 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock,
                 body;
               cycle_label:;
               }  */
-         tmp = fold_build2 (MINUS_EXPR, type, step, from);
-         tmp = fold_build2 (PLUS_EXPR, type, to, tmp);
-         tmp = fold_build2 (TRUNC_DIV_EXPR, type, tmp, step);
+         tmp = fold_build2_loc (input_location, MINUS_EXPR, type, step, from);
+         tmp = fold_build2_loc (input_location, PLUS_EXPR, type, to, tmp);
+         tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, type, tmp,
+                                step);
          tmp = gfc_evaluate_now (tmp, pblock);
          count = gfc_create_var (type, "count");
-         TREE_VEC_ELT (init, i) = build2_v (GIMPLE_MODIFY_STMT, count,
+         TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, count,
                                             build_int_cst (type, 0));
-         TREE_VEC_ELT (cond, i) = fold_build2 (LT_EXPR, boolean_type_node,
-                                               count, tmp);
-         TREE_VEC_ELT (incr, i) = fold_build2 (PLUS_EXPR, type, count,
-                                               build_int_cst (type, 1));
-         TREE_VEC_ELT (incr, i) = fold_build2 (GIMPLE_MODIFY_STMT, type,
-                                               count, TREE_VEC_ELT (incr, i));
+         TREE_VEC_ELT (cond, i) = fold_build2_loc (input_location, LT_EXPR,
+                                                   boolean_type_node,
+                                                   count, tmp);
+         TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR,
+                                                   type, count,
+                                                   build_int_cst (type, 1));
+         TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location,
+                                                   MODIFY_EXPR, type, count,
+                                                   TREE_VEC_ELT (incr, i));
 
          /* Initialize DOVAR.  */
-         tmp = fold_build2 (MULT_EXPR, type, count, step);
-         tmp = fold_build2 (PLUS_EXPR, type, from, tmp);
-         dovar_init = tree_cons (dovar, tmp, dovar_init);
+         tmp = fold_build2_loc (input_location, MULT_EXPR, type, count, step);
+         tmp = fold_build2_loc (input_location, PLUS_EXPR, type, from, tmp);
+         di = VEC_safe_push (dovar_init, heap, inits, NULL);
+         di->var = dovar;
+         di->init = tmp;
        }
 
       if (!dovar_found)
        {
-         tmp = build_omp_clause (OMP_CLAUSE_PRIVATE);
-         OMP_CLAUSE_DECL (tmp) = dovar;
+         tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
+         OMP_CLAUSE_DECL (tmp) = dovar_decl;
          omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
        }
       else if (dovar_found == 2)
@@ -1259,11 +1327,13 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock,
                 will have the value on entry of the last loop, rather
                 than value after iterator increment.  */
              tmp = gfc_evaluate_now (step, pblock);
-             tmp = fold_build2 (PLUS_EXPR, type, dovar, tmp);
-             tmp = fold_build2 (GIMPLE_MODIFY_STMT, type, dovar, tmp);
+             tmp = fold_build2_loc (input_location, PLUS_EXPR, type, dovar,
+                                    tmp);
+             tmp = fold_build2_loc (input_location, MODIFY_EXPR, type,
+                                    dovar, tmp);
              for (c = omp_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
                if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
-                   && OMP_CLAUSE_DECL (c) == dovar)
+                   && OMP_CLAUSE_DECL (c) == dovar_decl)
                  {
                    OMP_CLAUSE_LASTPRIVATE_STMT (c) = tmp;
                    break;
@@ -1273,10 +1343,11 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock,
            {
              for (c = par_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
                if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
-                   && OMP_CLAUSE_DECL (c) == dovar)
+                   && OMP_CLAUSE_DECL (c) == dovar_decl)
                  {
-                   tree l = build_omp_clause (OMP_CLAUSE_LASTPRIVATE);
-                   OMP_CLAUSE_DECL (l) = dovar;
+                   tree l = build_omp_clause (input_location,
+                                              OMP_CLAUSE_LASTPRIVATE);
+                   OMP_CLAUSE_DECL (l) = dovar_decl;
                    OMP_CLAUSE_CHAIN (l) = omp_clauses;
                    OMP_CLAUSE_LASTPRIVATE_STMT (l) = tmp;
                    omp_clauses = l;
@@ -1288,7 +1359,7 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock,
        }
       if (!simple)
        {
-         tmp = build_omp_clause (OMP_CLAUSE_PRIVATE);
+         tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
          OMP_CLAUSE_DECL (tmp) = count;
          omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
        }
@@ -1305,24 +1376,18 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock,
 
   gfc_start_block (&body);
 
-  dovar_init = nreverse (dovar_init);
-  while (dovar_init)
-    {
-      gfc_add_modify_stmt (&body, TREE_PURPOSE (dovar_init),
-                          TREE_VALUE (dovar_init));
-      dovar_init = TREE_CHAIN (dovar_init);
-    }
+  FOR_EACH_VEC_ELT (dovar_init, inits, ix, di)
+    gfc_add_modify (&body, di->var, di->init);
+  VEC_free (dovar_init, heap, inits);
 
   /* Cycle statement is implemented with a goto.  Exit statement must not be
      present for this loop.  */
   cycle_label = gfc_build_label_decl (NULL_TREE);
 
-  /* Put these labels where they can be found later. We put the
-     labels in a TREE_LIST node (because TREE_CHAIN is already
-     used). cycle_label goes in TREE_PURPOSE (backend_decl), exit
-     label in TREE_VALUE (backend_decl).  */
+  /* Put these labels where they can be found later.  */
 
-  code->block->backend_decl = tree_cons (cycle_label, NULL, NULL);
+  code->block->cycle_label = cycle_label;
+  code->block->exit_label = NULL_TREE;
 
   /* Main loop body.  */
   tmp = gfc_trans_omp_code (code->block->next, true);
@@ -1353,7 +1418,7 @@ static tree
 gfc_trans_omp_flush (void)
 {
   tree decl = built_in_decls [BUILT_IN_SYNCHRONIZE];
-  return build_call_expr (decl, 0);
+  return build_call_expr_loc (input_location, decl, 0);
 }
 
 static tree
@@ -1381,7 +1446,7 @@ gfc_trans_omp_parallel (gfc_code *code)
   omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
                                       code->loc);
   stmt = gfc_trans_omp_code (code->block->next, true);
-  stmt = build4_v (OMP_PARALLEL, stmt, omp_clauses, NULL, NULL);
+  stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses);
   gfc_add_expr_to_block (&block, stmt);
   return gfc_finish_block (&block);
 }
@@ -1421,7 +1486,7 @@ gfc_trans_omp_parallel_do (gfc_code *code)
     stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
   else
     poplevel (0, 0, 0);
-  stmt = build4_v (OMP_PARALLEL, stmt, omp_clauses, NULL, NULL);
+  stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses);
   OMP_PARALLEL_COMBINED (stmt) = 1;
   gfc_add_expr_to_block (&block, stmt);
   return gfc_finish_block (&block);
@@ -1446,7 +1511,7 @@ gfc_trans_omp_parallel_sections (gfc_code *code)
     stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
   else
     poplevel (0, 0, 0);
-  stmt = build4_v (OMP_PARALLEL, stmt, omp_clauses, NULL, NULL);
+  stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses);
   OMP_PARALLEL_COMBINED (stmt) = 1;
   gfc_add_expr_to_block (&block, stmt);
   return gfc_finish_block (&block);
@@ -1471,7 +1536,7 @@ gfc_trans_omp_parallel_workshare (gfc_code *code)
     stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
   else
     poplevel (0, 0, 0);
-  stmt = build4_v (OMP_PARALLEL, stmt, omp_clauses, NULL, NULL);
+  stmt = build2 (OMP_PARALLEL, void_type_node, stmt, omp_clauses);
   OMP_PARALLEL_COMBINED (stmt) = 1;
   gfc_add_expr_to_block (&block, stmt);
   return gfc_finish_block (&block);
@@ -1503,7 +1568,7 @@ gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses)
     }
   stmt = gfc_finish_block (&body);
 
-  stmt = build3_v (OMP_SECTIONS, stmt, omp_clauses, NULL_TREE);
+  stmt = build2 (OMP_SECTIONS, void_type_node, stmt, omp_clauses);
   gfc_add_expr_to_block (&block, stmt);
 
   return gfc_finish_block (&block);
@@ -1522,16 +1587,13 @@ static tree
 gfc_trans_omp_task (gfc_code *code)
 {
   stmtblock_t block;
-  tree stmt, body_stmt, omp_clauses;
+  tree stmt, omp_clauses;
 
   gfc_start_block (&block);
   omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses,
                                       code->loc);
-  body_stmt = gfc_trans_omp_code (code->block->next, true);
-  stmt = make_node (OMP_TASK);
-  TREE_TYPE (stmt) = void_type_node;
-  OMP_TASK_CLAUSES (stmt) = omp_clauses;
-  OMP_TASK_BODY (stmt) = body_stmt;
+  stmt = gfc_trans_omp_code (code->block->next, true);
+  stmt = build2 (OMP_TASK, void_type_node, stmt, omp_clauses);
   gfc_add_expr_to_block (&block, stmt);
   return gfc_finish_block (&block);
 }
@@ -1540,14 +1602,164 @@ static tree
 gfc_trans_omp_taskwait (void)
 {
   tree decl = built_in_decls [BUILT_IN_GOMP_TASKWAIT];
-  return build_call_expr (decl, 0);
+  return build_call_expr_loc (input_location, decl, 0);
 }
 
 static tree
 gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
 {
-  /* XXX */
-  return gfc_trans_omp_single (code, clauses);
+  tree res, tmp, stmt;
+  stmtblock_t block, *pblock = NULL;
+  stmtblock_t singleblock;
+  int saved_ompws_flags;
+  bool singleblock_in_progress = false;
+  /* True if previous gfc_code in workshare construct is not workshared.  */
+  bool prev_singleunit;
+
+  code = code->block->next;
+
+  pushlevel (0);
+
+  if (!code)
+    return build_empty_stmt (input_location);
+
+  gfc_start_block (&block);
+  pblock = &block;
+
+  ompws_flags = OMPWS_WORKSHARE_FLAG;
+  prev_singleunit = false;
+
+  /* Translate statements one by one to trees until we reach
+     the end of the workshare construct.  Adjacent gfc_codes that
+     are a single unit of work are clustered and encapsulated in a
+     single OMP_SINGLE construct.  */
+  for (; code; code = code->next)
+    {
+      if (code->here != 0)
+       {
+         res = gfc_trans_label_here (code);
+         gfc_add_expr_to_block (pblock, res);
+       }
+
+      /* No dependence analysis, use for clauses with wait.
+        If this is the last gfc_code, use default omp_clauses.  */
+      if (code->next == NULL && clauses->nowait)
+       ompws_flags |= OMPWS_NOWAIT;
+
+      /* By default, every gfc_code is a single unit of work.  */
+      ompws_flags |= OMPWS_CURR_SINGLEUNIT;
+      ompws_flags &= ~OMPWS_SCALARIZER_WS;
+
+      switch (code->op)
+       {
+       case EXEC_NOP:
+         res = NULL_TREE;
+         break;
+
+       case EXEC_ASSIGN:
+         res = gfc_trans_assign (code);
+         break;
+
+       case EXEC_POINTER_ASSIGN:
+         res = gfc_trans_pointer_assign (code);
+         break;
+
+       case EXEC_INIT_ASSIGN:
+         res = gfc_trans_init_assign (code);
+         break;
+
+       case EXEC_FORALL:
+         res = gfc_trans_forall (code);
+         break;
+
+       case EXEC_WHERE:
+         res = gfc_trans_where (code);
+         break;
+
+       case EXEC_OMP_ATOMIC:
+         res = gfc_trans_omp_directive (code);
+         break;
+
+       case EXEC_OMP_PARALLEL:
+       case EXEC_OMP_PARALLEL_DO:
+       case EXEC_OMP_PARALLEL_SECTIONS:
+       case EXEC_OMP_PARALLEL_WORKSHARE:
+       case EXEC_OMP_CRITICAL:
+         saved_ompws_flags = ompws_flags;
+         ompws_flags = 0;
+         res = gfc_trans_omp_directive (code);
+         ompws_flags = saved_ompws_flags;
+         break;
+       
+       default:
+         internal_error ("gfc_trans_omp_workshare(): Bad statement code");
+       }
+
+      gfc_set_backend_locus (&code->loc);
+
+      if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
+       {
+         if (prev_singleunit)
+           {
+             if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
+               /* Add current gfc_code to single block.  */
+               gfc_add_expr_to_block (&singleblock, res);
+             else
+               {
+                 /* Finish single block and add it to pblock.  */
+                 tmp = gfc_finish_block (&singleblock);
+                 tmp = build2 (OMP_SINGLE, void_type_node, tmp, NULL_TREE);
+                 gfc_add_expr_to_block (pblock, tmp);
+                 /* Add current gfc_code to pblock.  */
+                 gfc_add_expr_to_block (pblock, res);
+                 singleblock_in_progress = false;
+               }
+           }
+         else
+           {
+             if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
+               {
+                 /* Start single block.  */
+                 gfc_init_block (&singleblock);
+                 gfc_add_expr_to_block (&singleblock, res);
+                 singleblock_in_progress = true;
+               }
+             else
+               /* Add the new statement to the block.  */
+               gfc_add_expr_to_block (pblock, res);
+           }
+         prev_singleunit = (ompws_flags & OMPWS_CURR_SINGLEUNIT) != 0;
+       }
+    }
+
+  /* Finish remaining SINGLE block, if we were in the middle of one.  */
+  if (singleblock_in_progress)
+    {
+      /* Finish single block and add it to pblock.  */
+      tmp = gfc_finish_block (&singleblock);
+      tmp = build2 (OMP_SINGLE, void_type_node, tmp,
+                   clauses->nowait
+                   ? build_omp_clause (input_location, OMP_CLAUSE_NOWAIT)
+                   : NULL_TREE);
+      gfc_add_expr_to_block (pblock, tmp);
+    }
+
+  stmt = gfc_finish_block (pblock);
+  if (TREE_CODE (stmt) != BIND_EXPR)
+    {
+      if (!IS_EMPTY_STMT (stmt))
+       {
+         tree bindblock = poplevel (1, 0, 0);
+         stmt = build3_v (BIND_EXPR, NULL, stmt, bindblock);
+       }
+      else
+       poplevel (0, 0, 0);
+    }
+  else
+    poplevel (0, 0, 0);
+
+  ompws_flags = 0;
+  return stmt;
 }
 
 tree