[pf3gnuchains/gcc-fork.git] / gcc / fortran / trans-stmt.c

/* Statement translation -- generate GCC trees from gfc_code.
   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
   2011, 2012
   Free Software Foundation, Inc.
   Contributed by Paul Brook <paul@nowt.org>
   and Steven Bosscher <s.bosscher@student.tudelft.nl>

This file is part of GCC.

GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 3, or (at your option) any later
version.

GCC is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
for more details.

You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3.  If not see
<http://www.gnu.org/licenses/>.  */


#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tree.h"
#include "gfortran.h"
#include "flags.h"
#include "trans.h"
#include "trans-stmt.h"
#include "trans-types.h"
#include "trans-array.h"
#include "trans-const.h"
#include "arith.h"
#include "dependency.h"
#include "ggc.h"

typedef struct iter_info
{
  tree var;
  tree start;
  tree end;
  tree step;
  struct iter_info *next;
}
iter_info;

typedef struct forall_info
{
  iter_info *this_loop;
  tree mask;
  tree maskindex;
  int nvar;
  tree size;
  struct forall_info  *prev_nest;
}
forall_info;

static void gfc_trans_where_2 (gfc_code *, tree, bool,
                               forall_info *, stmtblock_t *);

/* Translate a F95 label number to a LABEL_EXPR.  */

tree
gfc_trans_label_here (gfc_code * code)
{
  return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here));
}


/* Given a variable expression which has been ASSIGNed to, find the decl
   containing the auxiliary variables.  For variables in common blocks this
   is a field_decl.  */

void
gfc_conv_label_variable (gfc_se * se, gfc_expr * expr)
{
  gcc_assert (expr->symtree->n.sym->attr.assign == 1);
  gfc_conv_expr (se, expr);
  /* Deals with variable in common block. Get the field declaration.  */
  if (TREE_CODE (se->expr) == COMPONENT_REF)
    se->expr = TREE_OPERAND (se->expr, 1);
  /* Deals with dummy argument. Get the parameter declaration.  */
  else if (TREE_CODE (se->expr) == INDIRECT_REF)
    se->expr = TREE_OPERAND (se->expr, 0);
}

/* Translate a label assignment statement.  */

tree
gfc_trans_label_assign (gfc_code * code)
{
  tree label_tree;
  gfc_se se;
  tree len;
  tree addr;
  tree len_tree;
  int label_len;

  /* Start a new block.  */
  gfc_init_se (&se, NULL);
  gfc_start_block (&se.pre);
  gfc_conv_label_variable (&se, code->expr1);

  len = GFC_DECL_STRING_LEN (se.expr);
  addr = GFC_DECL_ASSIGN_ADDR (se.expr);

  label_tree = gfc_get_label_decl (code->label1);

  if (code->label1->defined == ST_LABEL_TARGET)
    {
      label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
      len_tree = integer_minus_one_node;
    }
  else
    {
      gfc_expr *format = code->label1->format;

      label_len = format->value.character.length;
      len_tree = build_int_cst (gfc_charlen_type_node, label_len);
      label_tree = gfc_build_wide_string_const (format->ts.kind, label_len + 1,
                                                format->value.character.string);
      label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
    }

  gfc_add_modify (&se.pre, len, len_tree);
  gfc_add_modify (&se.pre, addr, label_tree);

  return gfc_finish_block (&se.pre);
}

/* Translate a GOTO statement.  */

tree
gfc_trans_goto (gfc_code * code)
{
  locus loc = code->loc;
  tree assigned_goto;
  tree target;
  tree tmp;
  gfc_se se;

  if (code->label1 != NULL)
    return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));

  /* ASSIGNED GOTO.  */
  gfc_init_se (&se, NULL);
  gfc_start_block (&se.pre);
  gfc_conv_label_variable (&se, code->expr1);
  tmp = GFC_DECL_STRING_LEN (se.expr);
  tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
                         build_int_cst (TREE_TYPE (tmp), -1));
  gfc_trans_runtime_check (true, false, tmp, &se.pre, &loc,
                           "Assigned label is not a target label");

  assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr);

  /* We're going to ignore a label list.  It does not really change the
     statement's semantics (because it is just a further restriction on
     what's legal code); before, we were comparing label addresses here, but
     that's a very fragile business and may break with optimization.  So
     just ignore it.  */

  target = fold_build1_loc (input_location, GOTO_EXPR, void_type_node,
                            assigned_goto);
  gfc_add_expr_to_block (&se.pre, target);
  return gfc_finish_block (&se.pre);
}


/* Translate an ENTRY statement.  Just adds a label for this entry point.  */
tree
gfc_trans_entry (gfc_code * code)
{
  return build1_v (LABEL_EXPR, code->ext.entry->label);
}


/* Replace a gfc_ss structure by another both in the gfc_se struct
   and the gfc_loopinfo struct.  This is used in gfc_conv_elemental_dependencies
   to replace a variable ss by the corresponding temporary.  */

static void
replace_ss (gfc_se *se, gfc_ss *old_ss, gfc_ss *new_ss)
{
  gfc_ss **sess, **loopss;

  /* The old_ss is a ss for a single variable.  */
  gcc_assert (old_ss->info->type == GFC_SS_SECTION);

  for (sess = &(se->ss); *sess != gfc_ss_terminator; sess = &((*sess)->next))
    if (*sess == old_ss)
      break;
  gcc_assert (*sess != gfc_ss_terminator);

  *sess = new_ss;
  new_ss->next = old_ss->next;


  for (loopss = &(se->loop->ss); *loopss != gfc_ss_terminator;
       loopss = &((*loopss)->loop_chain))
    if (*loopss == old_ss)
      break;
  gcc_assert (*loopss != gfc_ss_terminator);

  *loopss = new_ss;
  new_ss->loop_chain = old_ss->loop_chain;
  new_ss->loop = old_ss->loop;

  gfc_free_ss (old_ss);
}


/* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of
   elemental subroutines.  Make temporaries for output arguments if any such
   dependencies are found.  Output arguments are chosen because internal_unpack
   can be used, as is, to copy the result back to the variable.  */
static void
gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
                                 gfc_symbol * sym, gfc_actual_arglist * arg,
                                 gfc_dep_check check_variable)
{
  gfc_actual_arglist *arg0;
  gfc_expr *e;
  gfc_formal_arglist *formal;
  gfc_se parmse;
  gfc_ss *ss;
  gfc_symbol *fsym;
  tree data;
  tree size;
  tree tmp;

  if (loopse->ss == NULL)
    return;

  ss = loopse->ss;
  arg0 = arg;
  formal = sym->formal;

  /* Loop over all the arguments testing for dependencies.  */
  for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
    {
      e = arg->expr;
      if (e == NULL)
        continue;

      /* Obtain the info structure for the current argument.  */ 
      for (ss = loopse->ss; ss && ss != gfc_ss_terminator; ss = ss->next)
        if (ss->info->expr == e)
          break;

      /* If there is a dependency, create a temporary and use it
         instead of the variable.  */
      fsym = formal ? formal->sym : NULL;
      if (e->expr_type == EXPR_VARIABLE
            && e->rank && fsym
            && fsym->attr.intent != INTENT_IN
            && gfc_check_fncall_dependency (e, fsym->attr.intent,
                                            sym, arg0, check_variable))
        {
          tree initial, temptype;
          stmtblock_t temp_post;
          gfc_ss *tmp_ss;

          tmp_ss = gfc_get_array_ss (gfc_ss_terminator, NULL, ss->dimen,
                                     GFC_SS_SECTION);
          gfc_mark_ss_chain_used (tmp_ss, 1);
          tmp_ss->info->expr = ss->info->expr;
          replace_ss (loopse, ss, tmp_ss);

          /* Obtain the argument descriptor for unpacking.  */
          gfc_init_se (&parmse, NULL);
          parmse.want_pointer = 1;
          gfc_conv_expr_descriptor (&parmse, e, gfc_walk_expr (e));
          gfc_add_block_to_block (&se->pre, &parmse.pre);

          /* If we've got INTENT(INOUT) or a derived type with INTENT(OUT),
             initialize the array temporary with a copy of the values.  */
          if (fsym->attr.intent == INTENT_INOUT
                || (fsym->ts.type ==BT_DERIVED
                      && fsym->attr.intent == INTENT_OUT))
            initial = parmse.expr;
          /* For class expressions, we always initialize with the copy of
             the values.  */
          else if (e->ts.type == BT_CLASS)
            initial = parmse.expr;
          else
            initial = NULL_TREE;

          if (e->ts.type != BT_CLASS)
            {
             /* Find the type of the temporary to create; we don't use the type
                of e itself as this breaks for subcomponent-references in e
                (where the type of e is that of the final reference, but
                parmse.expr's type corresponds to the full derived-type).  */
             /* TODO: Fix this somehow so we don't need a temporary of the whole
                array but instead only the components referenced.  */
              temptype = TREE_TYPE (parmse.expr); /* Pointer to descriptor.  */
              gcc_assert (TREE_CODE (temptype) == POINTER_TYPE);
              temptype = TREE_TYPE (temptype);
              temptype = gfc_get_element_type (temptype);
            }

          else
            /* For class arrays signal that the size of the dynamic type has to
               be obtained from the vtable, using the 'initial' expression.  */
            temptype = NULL_TREE;

          /* Generate the temporary.  Cleaning up the temporary should be the
             very last thing done, so we add the code to a new block and add it
             to se->post as last instructions.  */
          size = gfc_create_var (gfc_array_index_type, NULL);
          data = gfc_create_var (pvoid_type_node, NULL);
          gfc_init_block (&temp_post);
          tmp = gfc_trans_create_temp_array (&se->pre, &temp_post, tmp_ss,
                                             temptype, initial, false, true,
                                             false, &arg->expr->where);
          gfc_add_modify (&se->pre, size, tmp);
          tmp = fold_convert (pvoid_type_node, tmp_ss->info->data.array.data);
          gfc_add_modify (&se->pre, data, tmp);

          /* Update other ss' delta.  */
          gfc_set_delta (loopse->loop);

          /* Copy the result back using unpack.....  */
          if (e->ts.type != BT_CLASS)
            tmp = build_call_expr_loc (input_location,
                        gfor_fndecl_in_unpack, 2, parmse.expr, data);
          else
            {
              /* ... except for class results where the copy is
                 unconditional.  */
              tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
              tmp = gfc_conv_descriptor_data_get (tmp);
              tmp = build_call_expr_loc (input_location,
                                         builtin_decl_explicit (BUILT_IN_MEMCPY),
                                         3, tmp, data, size);
            }
          gfc_add_expr_to_block (&se->post, tmp);

          /* parmse.pre is already added above.  */
          gfc_add_block_to_block (&se->post, &parmse.post);
          gfc_add_block_to_block (&se->post, &temp_post);
        }
    }
}


/* Get the interface symbol for the procedure corresponding to the given call.
   We can't get the procedure symbol directly as we have to handle the case
   of (deferred) type-bound procedures.  */

static gfc_symbol *
get_proc_ifc_for_call (gfc_code *c)
{
  gfc_symbol *sym;

  gcc_assert (c->op == EXEC_ASSIGN_CALL || c->op == EXEC_CALL);

  sym = gfc_get_proc_ifc_for_expr (c->expr1);

  /* Fall back/last resort try.  */
  if (sym == NULL)
    sym = c->resolved_sym;

  return sym;
}


/* Translate the CALL statement.  Builds a call to an F95 subroutine.  */

tree
gfc_trans_call (gfc_code * code, bool dependency_check,
                tree mask, tree count1, bool invert)
{
  gfc_se se;
  gfc_ss * ss;
  int has_alternate_specifier;
  gfc_dep_check check_variable;
  tree index = NULL_TREE;
  tree maskexpr = NULL_TREE;
  tree tmp;

  /* A CALL starts a new block because the actual arguments may have to
     be evaluated first.  */
  gfc_init_se (&se, NULL);
  gfc_start_block (&se.pre);

  gcc_assert (code->resolved_sym);

  ss = gfc_ss_terminator;
  if (code->resolved_sym->attr.elemental)
    ss = gfc_walk_elemental_function_args (ss, code->ext.actual,
                                           get_proc_ifc_for_call (code),
                                           GFC_SS_REFERENCE);

  /* Is not an elemental subroutine call with array valued arguments.  */
  if (ss == gfc_ss_terminator)
    {

      /* Translate the call.  */
      has_alternate_specifier
        = gfc_conv_procedure_call (&se, code->resolved_sym, code->ext.actual,
                                  code->expr1, NULL);

      /* A subroutine without side-effect, by definition, does nothing!  */
      TREE_SIDE_EFFECTS (se.expr) = 1;

      /* Chain the pieces together and return the block.  */
      if (has_alternate_specifier)
        {
          gfc_code *select_code;
          gfc_symbol *sym;
          select_code = code->next;
          gcc_assert(select_code->op == EXEC_SELECT);
          sym = select_code->expr1->symtree->n.sym;
          se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr);
          if (sym->backend_decl == NULL)
            sym->backend_decl = gfc_get_symbol_decl (sym);
          gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
        }
      else
        gfc_add_expr_to_block (&se.pre, se.expr);

      gfc_add_block_to_block (&se.pre, &se.post);
    }

  else
    {
      /* An elemental subroutine call with array valued arguments has
         to be scalarized.  */
      gfc_loopinfo loop;
      stmtblock_t body;
      stmtblock_t block;
      gfc_se loopse;
      gfc_se depse;

      /* gfc_walk_elemental_function_args renders the ss chain in the
         reverse order to the actual argument order.  */
      ss = gfc_reverse_ss (ss);

      /* Initialize the loop.  */
      gfc_init_se (&loopse, NULL);
      gfc_init_loopinfo (&loop);
      gfc_add_ss_to_loop (&loop, ss);

      gfc_conv_ss_startstride (&loop);
      /* TODO: gfc_conv_loop_setup generates a temporary for vector 
         subscripts.  This could be prevented in the elemental case  
         as temporaries are handled separatedly 
         (below in gfc_conv_elemental_dependencies).  */
      gfc_conv_loop_setup (&loop, &code->expr1->where);
      gfc_mark_ss_chain_used (ss, 1);

      /* Convert the arguments, checking for dependencies.  */
      gfc_copy_loopinfo_to_se (&loopse, &loop);
      loopse.ss = ss;

      /* For operator assignment, do dependency checking.  */
      if (dependency_check)
        check_variable = ELEM_CHECK_VARIABLE;
      else
        check_variable = ELEM_DONT_CHECK_VARIABLE;

      gfc_init_se (&depse, NULL);
      gfc_conv_elemental_dependencies (&depse, &loopse, code->resolved_sym,
                                       code->ext.actual, check_variable);

      gfc_add_block_to_block (&loop.pre,  &depse.pre);
      gfc_add_block_to_block (&loop.post, &depse.post);

      /* Generate the loop body.  */
      gfc_start_scalarized_body (&loop, &body);
      gfc_init_block (&block);

      if (mask && count1)
        {
          /* Form the mask expression according to the mask.  */
          index = count1;
          maskexpr = gfc_build_array_ref (mask, index, NULL);
          if (invert)
            maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
                                        TREE_TYPE (maskexpr), maskexpr);
        }

      /* Add the subroutine call to the block.  */
      gfc_conv_procedure_call (&loopse, code->resolved_sym,
                               code->ext.actual, code->expr1, NULL);

      if (mask && count1)
        {
          tmp = build3_v (COND_EXPR, maskexpr, loopse.expr,
                          build_empty_stmt (input_location));
          gfc_add_expr_to_block (&loopse.pre, tmp);
          tmp = fold_build2_loc (input_location, PLUS_EXPR,
                                 gfc_array_index_type,
                                 count1, gfc_index_one_node);
          gfc_add_modify (&loopse.pre, count1, tmp);
        }
      else
        gfc_add_expr_to_block (&loopse.pre, loopse.expr);

      gfc_add_block_to_block (&block, &loopse.pre);
      gfc_add_block_to_block (&block, &loopse.post);

      /* Finish up the loop block and the loop.  */
      gfc_add_expr_to_block (&body, gfc_finish_block (&block));
      gfc_trans_scalarizing_loops (&loop, &body);
      gfc_add_block_to_block (&se.pre, &loop.pre);
      gfc_add_block_to_block (&se.pre, &loop.post);
      gfc_add_block_to_block (&se.pre, &se.post);
      gfc_cleanup_loop (&loop);
    }

  return gfc_finish_block (&se.pre);
}


/* Translate the RETURN statement.  */

tree
gfc_trans_return (gfc_code * code)
{
  if (code->expr1)
    {
      gfc_se se;
      tree tmp;
      tree result;

      /* If code->expr is not NULL, this return statement must appear
         in a subroutine and current_fake_result_decl has already
         been generated.  */

      result = gfc_get_fake_result_decl (NULL, 0);
      if (!result)
        {
          gfc_warning ("An alternate return at %L without a * dummy argument",
                        &code->expr1->where);
          return gfc_generate_return ();
        }

      /* Start a new block for this statement.  */
      gfc_init_se (&se, NULL);
      gfc_start_block (&se.pre);

      gfc_conv_expr (&se, code->expr1);

      /* Note that the actually returned expression is a simple value and
         does not depend on any pointers or such; thus we can clean-up with
         se.post before returning.  */
      tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (result),
                             result, fold_convert (TREE_TYPE (result),
                             se.expr));
      gfc_add_expr_to_block (&se.pre, tmp);
      gfc_add_block_to_block (&se.pre, &se.post);

      tmp = gfc_generate_return ();
      gfc_add_expr_to_block (&se.pre, tmp);
      return gfc_finish_block (&se.pre);
    }

  return gfc_generate_return ();
}


/* Translate the PAUSE statement.  We have to translate this statement
   to a runtime library call.  */

tree
gfc_trans_pause (gfc_code * code)
{
  tree gfc_int4_type_node = gfc_get_int_type (4);
  gfc_se se;
  tree tmp;

  /* Start a new block for this statement.  */
  gfc_init_se (&se, NULL);
  gfc_start_block (&se.pre);


  if (code->expr1 == NULL)
    {
      tmp = build_int_cst (gfc_int4_type_node, 0);
      tmp = build_call_expr_loc (input_location,
                                 gfor_fndecl_pause_string, 2,
                                 build_int_cst (pchar_type_node, 0), tmp);
    }
  else if (code->expr1->ts.type == BT_INTEGER)
    {
      gfc_conv_expr (&se, code->expr1);
      tmp = build_call_expr_loc (input_location,
                                 gfor_fndecl_pause_numeric, 1,
                                 fold_convert (gfc_int4_type_node, se.expr));
    }
  else
    {
      gfc_conv_expr_reference (&se, code->expr1);
      tmp = build_call_expr_loc (input_location,
                             gfor_fndecl_pause_string, 2,
                             se.expr, se.string_length);
    }

  gfc_add_expr_to_block (&se.pre, tmp);

  gfc_add_block_to_block (&se.pre, &se.post);

  return gfc_finish_block (&se.pre);
}


/* Translate the STOP statement.  We have to translate this statement
   to a runtime library call.  */

tree
gfc_trans_stop (gfc_code *code, bool error_stop)
{
  tree gfc_int4_type_node = gfc_get_int_type (4);
  gfc_se se;
  tree tmp;

  /* Start a new block for this statement.  */
  gfc_init_se (&se, NULL);
  gfc_start_block (&se.pre);

  if (gfc_option.coarray == GFC_FCOARRAY_LIB && !error_stop)
    {
      /* Per F2008, 8.5.1 STOP implies a SYNC MEMORY.  */
      tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
      tmp = build_call_expr_loc (input_location, tmp, 0);
      gfc_add_expr_to_block (&se.pre, tmp);

      tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0);
      gfc_add_expr_to_block (&se.pre, tmp);
    }

  if (code->expr1 == NULL)
    {
      tmp = build_int_cst (gfc_int4_type_node, 0);
      tmp = build_call_expr_loc (input_location,
                                 error_stop
                                 ? (gfc_option.coarray == GFC_FCOARRAY_LIB
                                    ? gfor_fndecl_caf_error_stop_str
                                    : gfor_fndecl_error_stop_string)
                                 : gfor_fndecl_stop_string,
                                 2, build_int_cst (pchar_type_node, 0), tmp);
    }
  else if (code->expr1->ts.type == BT_INTEGER)
    {
      gfc_conv_expr (&se, code->expr1);
      tmp = build_call_expr_loc (input_location,
                                 error_stop
                                 ? (gfc_option.coarray == GFC_FCOARRAY_LIB
                                    ? gfor_fndecl_caf_error_stop
                                    : gfor_fndecl_error_stop_numeric)
                                 : gfor_fndecl_stop_numeric_f08, 1, 
                                 fold_convert (gfc_int4_type_node, se.expr));
    }
  else
    {
      gfc_conv_expr_reference (&se, code->expr1);
      tmp = build_call_expr_loc (input_location,
                                 error_stop
                                 ? (gfc_option.coarray == GFC_FCOARRAY_LIB
                                    ? gfor_fndecl_caf_error_stop_str
                                    : gfor_fndecl_error_stop_string)
                                 : gfor_fndecl_stop_string,
                                 2, se.expr, se.string_length);
    }

  gfc_add_expr_to_block (&se.pre, tmp);

  gfc_add_block_to_block (&se.pre, &se.post);

  return gfc_finish_block (&se.pre);
}


tree
gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op type ATTRIBUTE_UNUSED)
{
  gfc_se se, argse;
  tree stat = NULL_TREE, lock_acquired = NULL_TREE;

  /* Short cut: For single images without STAT= or LOCK_ACQUIRED
     return early. (ERRMSG= is always untouched for -fcoarray=single.)  */
  if (!code->expr2 && !code->expr4 && gfc_option.coarray != GFC_FCOARRAY_LIB)
    return NULL_TREE; 

  gfc_init_se (&se, NULL);
  gfc_start_block (&se.pre);

  if (code->expr2)
    {
      gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
      gfc_init_se (&argse, NULL);
      gfc_conv_expr_val (&argse, code->expr2);
      stat = argse.expr;
    }

  if (code->expr4)
    {
      gcc_assert (code->expr4->expr_type == EXPR_VARIABLE);
      gfc_init_se (&argse, NULL);
      gfc_conv_expr_val (&argse, code->expr4);
      lock_acquired = argse.expr;
    }

  if (stat != NULL_TREE)
    gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));

  if (lock_acquired != NULL_TREE)
    gfc_add_modify (&se.pre, lock_acquired,
                    fold_convert (TREE_TYPE (lock_acquired),
                                  boolean_true_node));

  return gfc_finish_block (&se.pre);
}


tree
gfc_trans_sync (gfc_code *code, gfc_exec_op type)
{
  gfc_se se, argse;
  tree tmp;
  tree images = NULL_TREE, stat = NULL_TREE,
       errmsg = NULL_TREE, errmsglen = NULL_TREE;

  /* Short cut: For single images without bound checking or without STAT=,
     return early. (ERRMSG= is always untouched for -fcoarray=single.)  */
  if (!code->expr2 && !(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
      && gfc_option.coarray != GFC_FCOARRAY_LIB)
    return NULL_TREE; 

  gfc_init_se (&se, NULL);
  gfc_start_block (&se.pre);

  if (code->expr1 && code->expr1->rank == 0)
    {
      gfc_init_se (&argse, NULL);
      gfc_conv_expr_val (&argse, code->expr1);
      images = argse.expr;
    }

  if (code->expr2)
    {
      gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
      gfc_init_se (&argse, NULL);
      gfc_conv_expr_val (&argse, code->expr2);
      stat = argse.expr;
    }
  else
    stat = null_pointer_node;

  if (code->expr3 && gfc_option.coarray == GFC_FCOARRAY_LIB
      && type != EXEC_SYNC_MEMORY)
    {
      gcc_assert (code->expr3->expr_type == EXPR_VARIABLE);
      gfc_init_se (&argse, NULL);
      gfc_conv_expr (&argse, code->expr3);
      gfc_conv_string_parameter (&argse);
      errmsg = gfc_build_addr_expr (NULL, argse.expr);
      errmsglen = argse.string_length;
    }
  else if (gfc_option.coarray == GFC_FCOARRAY_LIB && type != EXEC_SYNC_MEMORY)
    {
      errmsg = null_pointer_node;
      errmsglen = build_int_cst (integer_type_node, 0);
    }

  /* Check SYNC IMAGES(imageset) for valid image index.
     FIXME: Add a check for image-set arrays. */
  if (code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
      && code->expr1->rank == 0)
    {
      tree cond;
      if (gfc_option.coarray != GFC_FCOARRAY_LIB)
        cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
                                images, build_int_cst (TREE_TYPE (images), 1));
      else
        {
          tree cond2;
          cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
                                  images, gfort_gvar_caf_num_images);
          cond2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
                                   images,
                                   build_int_cst (TREE_TYPE (images), 1));
          cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
                                  boolean_type_node, cond, cond2);
        }
      gfc_trans_runtime_check (true, false, cond, &se.pre,
                               &code->expr1->where, "Invalid image number "
                               "%d in SYNC IMAGES",
                               fold_convert (integer_type_node, se.expr));
    }

   /* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the
      image control statements SYNC IMAGES and SYNC ALL.  */
   if (gfc_option.coarray == GFC_FCOARRAY_LIB)
     {
       tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
       tmp = build_call_expr_loc (input_location, tmp, 0);
       gfc_add_expr_to_block (&se.pre, tmp);
     }

  if (gfc_option.coarray != GFC_FCOARRAY_LIB || type == EXEC_SYNC_MEMORY)
    {
      /* Set STAT to zero.  */
      if (code->expr2)
        gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
    }
  else if (type == EXEC_SYNC_ALL)
    {
      /* SYNC ALL           =>   stat == null_pointer_node
         SYNC ALL(stat=s)   =>   stat has an integer type

         If "stat" has the wrong integer type, use a temp variable of
         the right type and later cast the result back into "stat".  */
      if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node)
        {
          if (TREE_TYPE (stat) == integer_type_node)
            stat = gfc_build_addr_expr (NULL, stat);
          
          tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
                                     3, stat, errmsg, errmsglen);
          gfc_add_expr_to_block (&se.pre, tmp);
        }
      else
        {
          tree tmp_stat = gfc_create_var (integer_type_node, "stat");

          tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
                                     3, gfc_build_addr_expr (NULL, tmp_stat),
                                     errmsg, errmsglen);
          gfc_add_expr_to_block (&se.pre, tmp);
          
          gfc_add_modify (&se.pre, stat,
                          fold_convert (TREE_TYPE (stat), tmp_stat));
        }
    }
  else
    {
      tree len;

      gcc_assert (type == EXEC_SYNC_IMAGES);

      if (!code->expr1)
        {
          len = build_int_cst (integer_type_node, -1);
          images = null_pointer_node;
        }
      else if (code->expr1->rank == 0)
        {
          len = build_int_cst (integer_type_node, 1);
          images = gfc_build_addr_expr (NULL_TREE, images);
        }
      else
        {
          /* FIXME.  */
          if (code->expr1->ts.kind != gfc_c_int_kind)
            gfc_fatal_error ("Sorry, only support for integer kind %d "
                             "implemented for image-set at %L",
                             gfc_c_int_kind, &code->expr1->where);

          gfc_conv_array_parameter (&se, code->expr1,
                                    gfc_walk_expr (code->expr1), true, NULL,
                                    NULL, &len);
          images = se.expr;

          tmp = gfc_typenode_for_spec (&code->expr1->ts);
          if (GFC_ARRAY_TYPE_P (tmp) || GFC_DESCRIPTOR_TYPE_P (tmp))
            tmp = gfc_get_element_type (tmp);

          len = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
                                 TREE_TYPE (len), len,
                                 fold_convert (TREE_TYPE (len),
                                               TYPE_SIZE_UNIT (tmp)));
          len = fold_convert (integer_type_node, len);
        }

      /* SYNC IMAGES(imgs)        => stat == null_pointer_node
         SYNC IMAGES(imgs,stat=s) => stat has an integer type

         If "stat" has the wrong integer type, use a temp variable of
         the right type and later cast the result back into "stat".  */
      if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node)
        {
          if (TREE_TYPE (stat) == integer_type_node)
            stat = gfc_build_addr_expr (NULL, stat);

          tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images, 
                                     5, fold_convert (integer_type_node, len),
                                     images, stat, errmsg, errmsglen);
          gfc_add_expr_to_block (&se.pre, tmp);
        }
      else
        {
          tree tmp_stat = gfc_create_var (integer_type_node, "stat");

          tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images, 
                                     5, fold_convert (integer_type_node, len),
                                     images, gfc_build_addr_expr (NULL, tmp_stat),
                                     errmsg, errmsglen);
          gfc_add_expr_to_block (&se.pre, tmp);

          gfc_add_modify (&se.pre, stat, 
                          fold_convert (TREE_TYPE (stat), tmp_stat));
        }
    }

  return gfc_finish_block (&se.pre);
}


/* Generate GENERIC for the IF construct. This function also deals with
   the simple IF statement, because the front end translates the IF
   statement into an IF construct.

   We translate:

        IF (cond) THEN
           then_clause
        ELSEIF (cond2)
           elseif_clause
        ELSE
           else_clause
        ENDIF

   into:

        pre_cond_s;
        if (cond_s)
          {
            then_clause;
          }
        else
          {
            pre_cond_s
            if (cond_s)
              {
                elseif_clause
              }
            else
              {
                else_clause;
              }
          }

   where COND_S is the simplified version of the predicate. PRE_COND_S
   are the pre side-effects produced by the translation of the
   conditional.
   We need to build the chain recursively otherwise we run into
   problems with folding incomplete statements.  */

static tree
gfc_trans_if_1 (gfc_code * code)
{
  gfc_se if_se;
  tree stmt, elsestmt;
  locus saved_loc;
  location_t loc;

  /* Check for an unconditional ELSE clause.  */
  if (!code->expr1)
    return gfc_trans_code (code->next);

  /* Initialize a statement builder for each block. Puts in NULL_TREEs.  */
  gfc_init_se (&if_se, NULL);
  gfc_start_block (&if_se.pre);

  /* Calculate the IF condition expression.  */
  if (code->expr1->where.lb)
    {
      gfc_save_backend_locus (&saved_loc);
      gfc_set_backend_locus (&code->expr1->where);
    }

  gfc_conv_expr_val (&if_se, code->expr1);

  if (code->expr1->where.lb)
    gfc_restore_backend_locus (&saved_loc);

  /* Translate the THEN clause.  */
  stmt = gfc_trans_code (code->next);

  /* Translate the ELSE clause.  */
  if (code->block)
    elsestmt = gfc_trans_if_1 (code->block);
  else
    elsestmt = build_empty_stmt (input_location);

  /* Build the condition expression and add it to the condition block.  */
  loc = code->expr1->where.lb ? code->expr1->where.lb->location : input_location;
  stmt = fold_build3_loc (loc, COND_EXPR, void_type_node, if_se.expr, stmt,
                          elsestmt);
  
  gfc_add_expr_to_block (&if_se.pre, stmt);

  /* Finish off this statement.  */
  return gfc_finish_block (&if_se.pre);
}

tree
gfc_trans_if (gfc_code * code)
{
  stmtblock_t body;
  tree exit_label;

  /* Create exit label so it is available for trans'ing the body code.  */
  exit_label = gfc_build_label_decl (NULL_TREE);
  code->exit_label = exit_label;

  /* Translate the actual code in code->block.  */
  gfc_init_block (&body);
  gfc_add_expr_to_block (&body, gfc_trans_if_1 (code->block));

  /* Add exit label.  */
  gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label));

  return gfc_finish_block (&body);
}


/* Translate an arithmetic IF expression.

   IF (cond) label1, label2, label3 translates to

    if (cond <= 0)
      {
        if (cond < 0)
          goto label1;
        else // cond == 0
          goto label2;
      }
    else // cond > 0
      goto label3;

   An optimized version can be generated in case of equal labels.
   E.g., if label1 is equal to label2, we can translate it to

    if (cond <= 0)
      goto label1;
    else
      goto label3;
*/

tree
gfc_trans_arithmetic_if (gfc_code * code)
{
  gfc_se se;
  tree tmp;
  tree branch1;
  tree branch2;
  tree zero;

  /* Start a new block.  */
  gfc_init_se (&se, NULL);
  gfc_start_block (&se.pre);

  /* Pre-evaluate COND.  */
  gfc_conv_expr_val (&se, code->expr1);
  se.expr = gfc_evaluate_now (se.expr, &se.pre);

  /* Build something to compare with.  */
  zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node);

  if (code->label1->value != code->label2->value)
    {
      /* If (cond < 0) take branch1 else take branch2.
         First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases.  */
      branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
      branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2));

      if (code->label1->value != code->label3->value)
        tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
                               se.expr, zero);
      else
        tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
                               se.expr, zero);

      branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node,
                                 tmp, branch1, branch2);
    }
  else
    branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));

  if (code->label1->value != code->label3->value
      && code->label2->value != code->label3->value)
    {
      /* if (cond <= 0) take branch1 else take branch2.  */
      branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3));
      tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
                             se.expr, zero);
      branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node,
                                 tmp, branch1, branch2);
    }

  /* Append the COND_EXPR to the evaluation of COND, and return.  */
  gfc_add_expr_to_block (&se.pre, branch1);
  return gfc_finish_block (&se.pre);
}


/* Translate a CRITICAL block. */
tree
gfc_trans_critical (gfc_code *code)
{
  stmtblock_t block;
  tree tmp;

  gfc_start_block (&block);

  if (gfc_option.coarray == GFC_FCOARRAY_LIB)
    {
      tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_critical, 0);
      gfc_add_expr_to_block (&block, tmp);
    }

  tmp = gfc_trans_code (code->block->next);
  gfc_add_expr_to_block (&block, tmp);

  if (gfc_option.coarray == GFC_FCOARRAY_LIB)
    {
      tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_end_critical,
                                 0);
      gfc_add_expr_to_block (&block, tmp);
    }


  return gfc_finish_block (&block);
}


/* Do proper initialization for ASSOCIATE names.  */

static void
trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
{
  gfc_expr *e;
  tree tmp;
  bool class_target;

  gcc_assert (sym->assoc);
  e = sym->assoc->target;

  class_target = (e->expr_type == EXPR_VARIABLE)
                    && (gfc_is_class_scalar_expr (e)
                        || gfc_is_class_array_ref (e, NULL));

  /* Do a `pointer assignment' with updated descriptor (or assign descriptor
     to array temporary) for arrays with either unknown shape or if associating
     to a variable.  */
  if (sym->attr.dimension && !class_target
      && (sym->as->type == AS_DEFERRED || sym->assoc->variable))
    {
      gfc_se se;
      gfc_ss *ss;
      tree desc;

      desc = sym->backend_decl;

      /* If association is to an expression, evaluate it and create temporary.
         Otherwise, get descriptor of target for pointer assignment.  */
      gfc_init_se (&se, NULL);
      ss = gfc_walk_expr (e);
      if (sym->assoc->variable)
        {
          se.direct_byref = 1;
          se.expr = desc;
        }
      gfc_conv_expr_descriptor (&se, e, ss);

      /* If we didn't already do the pointer assignment, set associate-name
         descriptor to the one generated for the temporary.  */
      if (!sym->assoc->variable)
        {
          int dim;

          gfc_add_modify (&se.pre, desc, se.expr);

          /* The generated descriptor has lower bound zero (as array
             temporary), shift bounds so we get lower bounds of 1.  */
          for (dim = 0; dim < e->rank; ++dim)
            gfc_conv_shift_descriptor_lbound (&se.pre, desc,
                                              dim, gfc_index_one_node);
        }

      /* Done, register stuff as init / cleanup code.  */
      gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
                            gfc_finish_block (&se.post));
    }

  /* CLASS arrays just need the descriptor to be directly assigned.  */
  else if (class_target && sym->attr.dimension)
    {
      gfc_se se;

      gfc_init_se (&se, NULL);
      se.descriptor_only = 1;
      gfc_conv_expr (&se, e);

      gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)));
      gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)));

      gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
      
      gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
                            gfc_finish_block (&se.post));
    }

  /* Do a scalar pointer assignment; this is for scalar variable targets.  */
  else if (gfc_is_associate_pointer (sym))
    {
      gfc_se se;

      gcc_assert (!sym->attr.dimension);

      gfc_init_se (&se, NULL);
      gfc_conv_expr (&se, e);

      tmp = TREE_TYPE (sym->backend_decl);
      tmp = gfc_build_addr_expr (tmp, se.expr);
      gfc_add_modify (&se.pre, sym->backend_decl, tmp);
      
      gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
                            gfc_finish_block (&se.post));
    }

  /* Do a simple assignment.  This is for scalar expressions, where we
     can simply use expression assignment.  */
  else
    {
      gfc_expr *lhs;

      lhs = gfc_lval_expr_from_sym (sym);
      tmp = gfc_trans_assignment (lhs, e, false, true);
      gfc_add_init_cleanup (block, tmp, NULL_TREE);
    }
}


/* Translate a BLOCK construct.  This is basically what we would do for a
   procedure body.  */

tree
gfc_trans_block_construct (gfc_code* code)
{
  gfc_namespace* ns;
  gfc_symbol* sym;
  gfc_wrapped_block block;
  tree exit_label;
  stmtblock_t body;
  gfc_association_list *ass;

  ns = code->ext.block.ns;
  gcc_assert (ns);
  sym = ns->proc_name;
  gcc_assert (sym);

  /* Process local variables.  */
  gcc_assert (!sym->tlink);
  sym->tlink = sym;
  gfc_process_block_locals (ns);

  /* Generate code including exit-label.  */
  gfc_init_block (&body);
  exit_label = gfc_build_label_decl (NULL_TREE);
  code->exit_label = exit_label;
  gfc_add_expr_to_block (&body, gfc_trans_code (ns->code));
  gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label));

  /* Finish everything.  */
  gfc_start_wrapped_block (&block, gfc_finish_block (&body));
  gfc_trans_deferred_vars (sym, &block);
  for (ass = code->ext.block.assoc; ass; ass = ass->next)
    trans_associate_var (ass->st->n.sym, &block);
    
  return gfc_finish_wrapped_block (&block);
}


/* Translate the simple DO construct.  This is where the loop variable has
   integer type and step +-1.  We can't use this in the general case
   because integer overflow and floating point errors could give incorrect
   results.
   We translate a do loop from:

   DO dovar = from, to, step
      body
   END DO

   to:

   [Evaluate loop bounds and step]
   dovar = from;
   if ((step > 0) ? (dovar <= to) : (dovar => to))
    {
      for (;;)
        {
          body;
   cycle_label:
          cond = (dovar == to);
          dovar += step;
          if (cond) goto end_label;
        }
      }
   end_label:

   This helps the optimizers by avoiding the extra induction variable
   used in the general case.  */

static tree
gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
                     tree from, tree to, tree step, tree exit_cond)
{
  stmtblock_t body;
  tree type;
  tree cond;
  tree tmp;
  tree saved_dovar = NULL;
  tree cycle_label;
  tree exit_label;
  location_t loc;
  
  type = TREE_TYPE (dovar);

  loc = code->ext.iterator->start->where.lb->location;

  /* Initialize the DO variable: dovar = from.  */
  gfc_add_modify_loc (loc, pblock, dovar,
                      fold_convert (TREE_TYPE(dovar), from));
  
  /* Save value for do-tinkering checking. */
  if (gfc_option.rtcheck & GFC_RTCHECK_DO)
    {
      saved_dovar = gfc_create_var (type, ".saved_dovar");
      gfc_add_modify_loc (loc, pblock, saved_dovar, dovar);
    }

  /* Cycle and exit statements are implemented with gotos.  */
  cycle_label = gfc_build_label_decl (NULL_TREE);
  exit_label = gfc_build_label_decl (NULL_TREE);

  /* Put the labels where they can be found later. See gfc_trans_do().  */
  code->cycle_label = cycle_label;
  code->exit_label = exit_label;

  /* Loop body.  */
  gfc_start_block (&body);

  /* Main loop body.  */
  tmp = gfc_trans_code_cond (code->block->next, exit_cond);
  gfc_add_expr_to_block (&body, tmp);

  /* Label for cycle statements (if needed).  */
  if (TREE_USED (cycle_label))
    {
      tmp = build1_v (LABEL_EXPR, cycle_label);
      gfc_add_expr_to_block (&body, tmp);
    }

  /* Check whether someone has modified the loop variable. */
  if (gfc_option.rtcheck & GFC_RTCHECK_DO)
    {
      tmp = fold_build2_loc (loc, NE_EXPR, boolean_type_node,
                             dovar, saved_dovar);
      gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
                               "Loop variable has been modified");
    }

  /* Exit the loop if there is an I/O result condition or error.  */
  if (exit_cond)
    {
      tmp = build1_v (GOTO_EXPR, exit_label);
      tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
                             exit_cond, tmp,
                             build_empty_stmt (loc));
      gfc_add_expr_to_block (&body, tmp);
    }

  /* Evaluate the loop condition.  */
  cond = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, dovar,
                          to);
  cond = gfc_evaluate_now_loc (loc, cond, &body);

  /* Increment the loop variable.  */
  tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step);
  gfc_add_modify_loc (loc, &body, dovar, tmp);

  if (gfc_option.rtcheck & GFC_RTCHECK_DO)
    gfc_add_modify_loc (loc, &body, saved_dovar, dovar);

  /* The loop exit.  */
  tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label);
  TREE_USED (exit_label) = 1;
  tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
                         cond, tmp, build_empty_stmt (loc));
  gfc_add_expr_to_block (&body, tmp);

  /* Finish the loop body.  */
  tmp = gfc_finish_block (&body);
  tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp);

  /* Only execute the loop if the number of iterations is positive.  */
  if (tree_int_cst_sgn (step) > 0)
    cond = fold_build2_loc (loc, LE_EXPR, boolean_type_node, dovar,
                            to);
  else
    cond = fold_build2_loc (loc, GE_EXPR, boolean_type_node, dovar,
                            to);
  tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, cond, tmp,
                         build_empty_stmt (loc));
  gfc_add_expr_to_block (pblock, tmp);

  /* Add the exit label.  */
  tmp = build1_v (LABEL_EXPR, exit_label);
  gfc_add_expr_to_block (pblock, tmp);

  return gfc_finish_block (pblock);
}

/* Translate the DO construct.  This obviously is one of the most
   important ones to get right with any compiler, but especially
   so for Fortran.

   We special case some loop forms as described in gfc_trans_simple_do.
   For other cases we implement them with a separate loop count,
   as described in the standard.

   We translate a do loop from:

   DO dovar = from, to, step
      body
   END DO

   to:

   [evaluate loop bounds and step]
   empty = (step > 0 ? to < from : to > from);
   countm1 = (to - from) / step;
   dovar = from;
   if (empty) goto exit_label;
   for (;;)
     {
       body;
cycle_label:
       dovar += step
       if (countm1 ==0) goto exit_label;
       countm1--;
     }
exit_label:

   countm1 is an unsigned integer.  It is equal to the loop count minus one,
   because the loop count itself can overflow.  */

tree
gfc_trans_do (gfc_code * code, tree exit_cond)
{
  gfc_se se;
  tree dovar;
  tree saved_dovar = NULL;
  tree from;
  tree to;
  tree step;
  tree countm1;
  tree type;
  tree utype;
  tree cond;
  tree cycle_label;
  tree exit_label;
  tree tmp;
  tree pos_step;
  stmtblock_t block;
  stmtblock_t body;
  location_t loc;

  gfc_start_block (&block);

  loc = code->ext.iterator->start->where.lb->location;

  /* Evaluate all the expressions in the iterator.  */
  gfc_init_se (&se, NULL);
  gfc_conv_expr_lhs (&se, code->ext.iterator->var);
  gfc_add_block_to_block (&block, &se.pre);
  dovar = se.expr;
  type = TREE_TYPE (dovar);

  gfc_init_se (&se, NULL);
  gfc_conv_expr_val (&se, code->ext.iterator->start);
  gfc_add_block_to_block (&block, &se.pre);
  from = gfc_evaluate_now (se.expr, &block);

  gfc_init_se (&se, NULL);
  gfc_conv_expr_val (&se, code->ext.iterator->end);
  gfc_add_block_to_block (&block, &se.pre);
  to = gfc_evaluate_now (se.expr, &block);

  gfc_init_se (&se, NULL);
  gfc_conv_expr_val (&se, code->ext.iterator->step);
  gfc_add_block_to_block (&block, &se.pre);
  step = gfc_evaluate_now (se.expr, &block);

  if (gfc_option.rtcheck & GFC_RTCHECK_DO)
    {
      tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, step,
                             build_zero_cst (type));
      gfc_trans_runtime_check (true, false, tmp, &block, &code->loc,
                               "DO step value is zero");
    }

  /* Special case simple loops.  */
  if (TREE_CODE (type) == INTEGER_TYPE
      && (integer_onep (step)
        || tree_int_cst_equal (step, integer_minus_one_node)))
    return gfc_trans_simple_do (code, &block, dovar, from, to, step, exit_cond);

  pos_step = fold_build2_loc (loc, GT_EXPR, boolean_type_node, step,
                              build_zero_cst (type));

  if (TREE_CODE (type) == INTEGER_TYPE)
    utype = unsigned_type_for (type);
  else
    utype = unsigned_type_for (gfc_array_index_type);
  countm1 = gfc_create_var (utype, "countm1");

  /* Cycle and exit statements are implemented with gotos.  */
  cycle_label = gfc_build_label_decl (NULL_TREE);
  exit_label = gfc_build_label_decl (NULL_TREE);
  TREE_USED (exit_label) = 1;

  /* Put these labels where they can be found later.  */
  code->cycle_label = cycle_label;
  code->exit_label = exit_label;

  /* Initialize the DO variable: dovar = from.  */
  gfc_add_modify (&block, dovar, from);

  /* Save value for do-tinkering checking. */
  if (gfc_option.rtcheck & GFC_RTCHECK_DO)
    {
      saved_dovar = gfc_create_var (type, ".saved_dovar");
      gfc_add_modify_loc (loc, &block, saved_dovar, dovar);
    }

  /* Initialize loop count and jump to exit label if the loop is empty.
     This code is executed before we enter the loop body. We generate:
     step_sign = sign(1,step);
     if (step > 0)
       {
         if (to < from)
           goto exit_label;
       }
     else
       {
         if (to > from)
           goto exit_label;
       }
       countm1 = (to*step_sign - from*step_sign) / (step*step_sign);

  */

  if (TREE_CODE (type) == INTEGER_TYPE)
    {
      tree pos, neg, step_sign, to2, from2, step2;

      /* Calculate SIGN (1,step), as (step < 0 ? -1 : 1)  */

      tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, step,
                             build_int_cst (TREE_TYPE (step), 0));
      step_sign = fold_build3_loc (loc, COND_EXPR, type, tmp, 
                                   build_int_cst (type, -1), 
                                   build_int_cst (type, 1));

      tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, to, from);
      pos = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
                             fold_build1_loc (loc, GOTO_EXPR, void_type_node,
                                              exit_label),
                             build_empty_stmt (loc));

      tmp = fold_build2_loc (loc, GT_EXPR, boolean_type_node, to,
                             from);
      neg = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
                             fold_build1_loc (loc, GOTO_EXPR, void_type_node,
                                              exit_label),
                             build_empty_stmt (loc));
      tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
                             pos_step, pos, neg);

      gfc_add_expr_to_block (&block, tmp);

      /* Calculate the loop count.  to-from can overflow, so
         we cast to unsigned.  */

      to2 = fold_build2_loc (loc, MULT_EXPR, type, step_sign, to);
      from2 = fold_build2_loc (loc, MULT_EXPR, type, step_sign, from);
      step2 = fold_build2_loc (loc, MULT_EXPR, type, step_sign, step);
      step2 = fold_convert (utype, step2);
      tmp = fold_build2_loc (loc, MINUS_EXPR, type, to2, from2);
      tmp = fold_convert (utype, tmp);
      tmp = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype, tmp, step2);
      tmp = fold_build2_loc (loc, MODIFY_EXPR, void_type_node, countm1, tmp);
      gfc_add_expr_to_block (&block, tmp);
    }
  else
    {
      /* TODO: We could use the same width as the real type.
         This would probably cause more problems that it solves
         when we implement "long double" types.  */

      tmp = fold_build2_loc (loc, MINUS_EXPR, type, to, from);
      tmp = fold_build2_loc (loc, RDIV_EXPR, type, tmp, step);
      tmp = fold_build1_loc (loc, FIX_TRUNC_EXPR, utype, tmp);
      gfc_add_modify (&block, countm1, tmp);

      /* We need a special check for empty loops:
         empty = (step > 0 ? to < from : to > from);  */
      tmp = fold_build3_loc (loc, COND_EXPR, boolean_type_node, pos_step,
                             fold_build2_loc (loc, LT_EXPR,
                                              boolean_type_node, to, from),
                             fold_build2_loc (loc, GT_EXPR,
                                              boolean_type_node, to, from));
      /* If the loop is empty, go directly to the exit label.  */
      tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
                         build1_v (GOTO_EXPR, exit_label),
                         build_empty_stmt (input_location));
      gfc_add_expr_to_block (&block, tmp);
    }

  /* Loop body.  */
  gfc_start_block (&body);

  /* Main loop body.  */
  tmp = gfc_trans_code_cond (code->block->next, exit_cond);
  gfc_add_expr_to_block (&body, tmp);

  /* Label for cycle statements (if needed).  */
  if (TREE_USED (cycle_label))
    {
      tmp = build1_v (LABEL_EXPR, cycle_label);
      gfc_add_expr_to_block (&body, tmp);
    }

  /* Check whether someone has modified the loop variable. */
  if (gfc_option.rtcheck & GFC_RTCHECK_DO)
    {
      tmp = fold_build2_loc (loc, NE_EXPR, boolean_type_node, dovar,
                             saved_dovar);
      gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
                               "Loop variable has been modified");
    }

  /* Exit the loop if there is an I/O result condition or error.  */
  if (exit_cond)
    {
      tmp = build1_v (GOTO_EXPR, exit_label);
      tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
                             exit_cond, tmp,
                             build_empty_stmt (input_location));
      gfc_add_expr_to_block (&body, tmp);
    }

  /* Increment the loop variable.  */
  tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step);
  gfc_add_modify_loc (loc, &body, dovar, tmp);

  if (gfc_option.rtcheck & GFC_RTCHECK_DO)
    gfc_add_modify_loc (loc, &body, saved_dovar, dovar);

  /* End with the loop condition.  Loop until countm1 == 0.  */
  cond = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, countm1,
                          build_int_cst (utype, 0));
  tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label);
  tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
                         cond, tmp, build_empty_stmt (loc));
  gfc_add_expr_to_block (&body, tmp);

  /* Decrement the loop count.  */
  tmp = fold_build2_loc (loc, MINUS_EXPR, utype, countm1,
                         build_int_cst (utype, 1));
  gfc_add_modify_loc (loc, &body, countm1, tmp);

  /* End of loop body.  */
  tmp = gfc_finish_block (&body);

  /* The for loop itself.  */
  tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp);
  gfc_add_expr_to_block (&block, tmp);

  /* Add the exit label.  */
  tmp = build1_v (LABEL_EXPR, exit_label);
  gfc_add_expr_to_block (&block, tmp);

  return gfc_finish_block (&block);
}


/* Translate the DO WHILE construct.

   We translate

   DO WHILE (cond)
      body
   END DO

   to:

   for ( ; ; )
     {
       pre_cond;
       if (! cond) goto exit_label;
       body;
cycle_label:
     }
exit_label:

   Because the evaluation of the exit condition `cond' may have side
   effects, we can't do much for empty loop bodies.  The backend optimizers
   should be smart enough to eliminate any dead loops.  */

tree
gfc_trans_do_while (gfc_code * code)
{
  gfc_se cond;
  tree tmp;
  tree cycle_label;
  tree exit_label;
  stmtblock_t block;

  /* Everything we build here is part of the loop body.  */
  gfc_start_block (&block);

  /* Cycle and exit statements are implemented with gotos.  */
  cycle_label = gfc_build_label_decl (NULL_TREE);
  exit_label = gfc_build_label_decl (NULL_TREE);

  /* Put the labels where they can be found later. See gfc_trans_do().  */
  code->cycle_label = cycle_label;
  code->exit_label = exit_label;

  /* Create a GIMPLE version of the exit condition.  */
  gfc_init_se (&cond, NULL);
  gfc_conv_expr_val (&cond, code->expr1);
  gfc_add_block_to_block (&block, &cond.pre);
  cond.expr = fold_build1_loc (code->expr1->where.lb->location,
                               TRUTH_NOT_EXPR, boolean_type_node, cond.expr);

  /* Build "IF (! cond) GOTO exit_label".  */
  tmp = build1_v (GOTO_EXPR, exit_label);
  TREE_USED (exit_label) = 1;
  tmp = fold_build3_loc (code->expr1->where.lb->location, COND_EXPR,
                         void_type_node, cond.expr, tmp,
                         build_empty_stmt (code->expr1->where.lb->location));
  gfc_add_expr_to_block (&block, tmp);

  /* The main body of the loop.  */
  tmp = gfc_trans_code (code->block->next);
  gfc_add_expr_to_block (&block, tmp);

  /* Label for cycle statements (if needed).  */
  if (TREE_USED (cycle_label))
    {
      tmp = build1_v (LABEL_EXPR, cycle_label);
      gfc_add_expr_to_block (&block, tmp);
    }

  /* End of loop body.  */
  tmp = gfc_finish_block (&block);

  gfc_init_block (&block);
  /* Build the loop.  */
  tmp = fold_build1_loc (code->expr1->where.lb->location, LOOP_EXPR,
                         void_type_node, tmp);
  gfc_add_expr_to_block (&block, tmp);

  /* Add the exit label.  */
  tmp = build1_v (LABEL_EXPR, exit_label);
  gfc_add_expr_to_block (&block, tmp);

  return gfc_finish_block (&block);
}


/* Translate the SELECT CASE construct for INTEGER case expressions,
   without killing all potential optimizations.  The problem is that
   Fortran allows unbounded cases, but the back-end does not, so we
   need to intercept those before we enter the equivalent SWITCH_EXPR
   we can build.

   For example, we translate this,

   SELECT CASE (expr)
      CASE (:100,101,105:115)
         block_1
      CASE (190:199,200:)
         block_2
      CASE (300)
         block_3
      CASE DEFAULT
         block_4
   END SELECT

   to the GENERIC equivalent,

     switch (expr)
       {
         case (minimum value for typeof(expr) ... 100:
         case 101:
         case 105 ... 114:
           block1:
           goto end_label;

         case 200 ... (maximum value for typeof(expr):
         case 190 ... 199:
           block2;
           goto end_label;

         case 300:
           block_3;
           goto end_label;

         default:
           block_4;
           goto end_label;
       }

     end_label:  */

static tree
gfc_trans_integer_select (gfc_code * code)
{
  gfc_code *c;
  gfc_case *cp;
  tree end_label;
  tree tmp;
  gfc_se se;
  stmtblock_t block;
  stmtblock_t body;

  gfc_start_block (&block);

  /* Calculate the switch expression.  */
  gfc_init_se (&se, NULL);
  gfc_conv_expr_val (&se, code->expr1);
  gfc_add_block_to_block (&block, &se.pre);

  end_label = gfc_build_label_decl (NULL_TREE);

  gfc_init_block (&body);

  for (c = code->block; c; c = c->block)
    {
      for (cp = c->ext.block.case_list; cp; cp = cp->next)
        {
          tree low, high;
          tree label;

          /* Assume it's the default case.  */
          low = high = NULL_TREE;

          if (cp->low)
            {
              low = gfc_conv_mpz_to_tree (cp->low->value.integer,
                                          cp->low->ts.kind);

              /* If there's only a lower bound, set the high bound to the
                 maximum value of the case expression.  */
              if (!cp->high)
                high = TYPE_MAX_VALUE (TREE_TYPE (se.expr));
            }

          if (cp->high)
            {
              /* Three cases are possible here:

                 1) There is no lower bound, e.g. CASE (:N).
                 2) There is a lower bound .NE. high bound, that is
                    a case range, e.g. CASE (N:M) where M>N (we make
                    sure that M>N during type resolution).
                 3) There is a lower bound, and it has the same value
                    as the high bound, e.g. CASE (N:N).  This is our
                    internal representation of CASE(N).

                 In the first and second case, we need to set a value for
                 high.  In the third case, we don't because the GCC middle
                 end represents a single case value by just letting high be
                 a NULL_TREE.  We can't do that because we need to be able
                 to represent unbounded cases.  */

              if (!cp->low
                  || (cp->low
                      && mpz_cmp (cp->low->value.integer,
                                  cp->high->value.integer) != 0))
                high = gfc_conv_mpz_to_tree (cp->high->value.integer,
                                             cp->high->ts.kind);

              /* Unbounded case.  */
              if (!cp->low)
                low = TYPE_MIN_VALUE (TREE_TYPE (se.expr));
            }

          /* Build a label.  */
          label = gfc_build_label_decl (NULL_TREE);

          /* Add this case label.
             Add parameter 'label', make it match GCC backend.  */
          tmp = build_case_label (low, high, label);
          gfc_add_expr_to_block (&body, tmp);
        }

      /* Add the statements for this case.  */
      tmp = gfc_trans_code (c->next);
      gfc_add_expr_to_block (&body, tmp);

      /* Break to the end of the construct.  */
      tmp = build1_v (GOTO_EXPR, end_label);
      gfc_add_expr_to_block (&body, tmp);
    }

  tmp = gfc_finish_block (&body);
  tmp = build3_v (SWITCH_EXPR, se.expr, tmp, NULL_TREE);
  gfc_add_expr_to_block (&block, tmp);

  tmp = build1_v (LABEL_EXPR, end_label);
  gfc_add_expr_to_block (&block, tmp);

  return gfc_finish_block (&block);
}


/* Translate the SELECT CASE construct for LOGICAL case expressions.

   There are only two cases possible here, even though the standard
   does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
   .FALSE., and DEFAULT.

   We never generate more than two blocks here.  Instead, we always
   try to eliminate the DEFAULT case.  This way, we can translate this
   kind of SELECT construct to a simple

   if {} else {};

   expression in GENERIC.  */

static tree
gfc_trans_logical_select (gfc_code * code)
{
  gfc_code *c;
  gfc_code *t, *f, *d;
  gfc_case *cp;
  gfc_se se;
  stmtblock_t block;

  /* Assume we don't have any cases at all.  */
  t = f = d = NULL;

  /* Now see which ones we actually do have.  We can have at most two
     cases in a single case list: one for .TRUE. and one for .FALSE.
     The default case is always separate.  If the cases for .TRUE. and
     .FALSE. are in the same case list, the block for that case list
     always executed, and we don't generate code a COND_EXPR.  */
  for (c = code->block; c; c = c->block)
    {
      for (cp = c->ext.block.case_list; cp; cp = cp->next)
        {
          if (cp->low)
            {
              if (cp->low->value.logical == 0) /* .FALSE.  */
                f = c;
              else /* if (cp->value.logical != 0), thus .TRUE.  */
                t = c;
            }
          else
            d = c;
        }
    }

  /* Start a new block.  */
  gfc_start_block (&block);

  /* Calculate the switch expression.  We always need to do this
     because it may have side effects.  */
  gfc_init_se (&se, NULL);
  gfc_conv_expr_val (&se, code->expr1);
  gfc_add_block_to_block (&block, &se.pre);

  if (t == f && t != NULL)
    {
      /* Cases for .TRUE. and .FALSE. are in the same block.  Just
         translate the code for these cases, append it to the current
         block.  */
      gfc_add_expr_to_block (&block, gfc_trans_code (t->next));
    }
  else
    {
      tree true_tree, false_tree, stmt;

      true_tree = build_empty_stmt (input_location);
      false_tree = build_empty_stmt (input_location);

      /* If we have a case for .TRUE. and for .FALSE., discard the default case.
          Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
          make the missing case the default case.  */
      if (t != NULL && f != NULL)
        d = NULL;
      else if (d != NULL)
        {
          if (t == NULL)
            t = d;
          else
            f = d;
        }

      /* Translate the code for each of these blocks, and append it to
         the current block.  */
      if (t != NULL)
        true_tree = gfc_trans_code (t->next);

      if (f != NULL)
        false_tree = gfc_trans_code (f->next);

      stmt = fold_build3_loc (input_location, COND_EXPR, void_type_node,
                              se.expr, true_tree, false_tree);
      gfc_add_expr_to_block (&block, stmt);
    }

  return gfc_finish_block (&block);
}


/* The jump table types are stored in static variables to avoid
   constructing them from scratch every single time.  */
static GTY(()) tree select_struct[2];

/* Translate the SELECT CASE construct for CHARACTER case expressions.
   Instead of generating compares and jumps, it is far simpler to
   generate a data structure describing the cases in order and call a
   library subroutine that locates the right case.
   This is particularly true because this is the only case where we
   might have to dispose of a temporary.
   The library subroutine returns a pointer to jump to or NULL if no
   branches are to be taken.  */

static tree
gfc_trans_character_select (gfc_code *code)
{
  tree init, end_label, tmp, type, case_num, label, fndecl;
  stmtblock_t block, body;
  gfc_case *cp, *d;
  gfc_code *c;
  gfc_se se, expr1se;
  int n, k;
  VEC(constructor_elt,gc) *inits = NULL;

  tree pchartype = gfc_get_pchar_type (code->expr1->ts.kind);

  /* The jump table types are stored in static variables to avoid
     constructing them from scratch every single time.  */
  static tree ss_string1[2], ss_string1_len[2];
  static tree ss_string2[2], ss_string2_len[2];
  static tree ss_target[2];

  cp = code->block->ext.block.case_list;
  while (cp->left != NULL)
    cp = cp->left;

  /* Generate the body */
  gfc_start_block (&block);
  gfc_init_se (&expr1se, NULL);
  gfc_conv_expr_reference (&expr1se, code->expr1);

  gfc_add_block_to_block (&block, &expr1se.pre);

  end_label = gfc_build_label_decl (NULL_TREE);

  gfc_init_block (&body);

  /* Attempt to optimize length 1 selects.  */
  if (integer_onep (expr1se.string_length))
    {
      for (d = cp; d; d = d->right)
        {
          int i;
          if (d->low)
            {
              gcc_assert (d->low->expr_type == EXPR_CONSTANT
                          && d->low->ts.type == BT_CHARACTER);
              if (d->low->value.character.length > 1)
                {
                  for (i = 1; i < d->low->value.character.length; i++)
                    if (d->low->value.character.string[i] != ' ')
                      break;
                  if (i != d->low->value.character.length)
                    {
                      if (optimize && d->high && i == 1)
                        {
                          gcc_assert (d->high->expr_type == EXPR_CONSTANT
                                      && d->high->ts.type == BT_CHARACTER);
                          if (d->high->value.character.length > 1
                              && (d->low->value.character.string[0]
                                  == d->high->value.character.string[0])
                              && d->high->value.character.string[1] != ' '
                              && ((d->low->value.character.string[1] < ' ')
                                  == (d->high->value.character.string[1]
                                      < ' ')))
                            continue;
                        }
                      break;
                    }
                }
            }
          if (d->high)
            {
              gcc_assert (d->high->expr_type == EXPR_CONSTANT
                          && d->high->ts.type == BT_CHARACTER);
              if (d->high->value.character.length > 1)
                {
                  for (i = 1; i < d->high->value.character.length; i++)
                    if (d->high->value.character.string[i] != ' ')
                      break;
                  if (i != d->high->value.character.length)
                    break;
                }
            }
        }
      if (d == NULL)
        {
          tree ctype = gfc_get_char_type (code->expr1->ts.kind);

          for (c = code->block; c; c = c->block)
            {
              for (cp = c->ext.block.case_list; cp; cp = cp->next)
                {
                  tree low, high;
                  tree label;
                  gfc_char_t r;

                  /* Assume it's the default case.  */
                  low = high = NULL_TREE;

                  if (cp->low)
                    {
                      /* CASE ('ab') or CASE ('ab':'az') will never match
                         any length 1 character.  */
                      if (cp->low->value.character.length > 1
                          && cp->low->value.character.string[1] != ' ')
                        continue;

                      if (cp->low->value.character.length > 0)
                        r = cp->low->value.character.string[0];
                      else
                        r = ' ';
                      low = build_int_cst (ctype, r);

                      /* If there's only a lower bound, set the high bound
                         to the maximum value of the case expression.  */
                      if (!cp->high)
                        high = TYPE_MAX_VALUE (ctype);
                    }

                  if (cp->high)
                    {
                      if (!cp->low
                          || (cp->low->value.character.string[0]
                              != cp->high->value.character.string[0]))
                        {
                          if (cp->high->value.character.length > 0)
                            r = cp->high->value.character.string[0];
                          else
                            r = ' ';
                          high = build_int_cst (ctype, r);
                        }

                      /* Unbounded case.  */
                      if (!cp->low)
                        low = TYPE_MIN_VALUE (ctype);
                    }

                  /* Build a label.  */
                  label = gfc_build_label_decl (NULL_TREE);

                  /* Add this case label.
                     Add parameter 'label', make it match GCC backend.  */
                  tmp = build_case_label (low, high, label);
                  gfc_add_expr_to_block (&body, tmp);
                }

              /* Add the statements for this case.  */
              tmp = gfc_trans_code (c->next);
              gfc_add_expr_to_block (&body, tmp);

              /* Break to the end of the construct.  */
              tmp = build1_v (GOTO_EXPR, end_label);
              gfc_add_expr_to_block (&body, tmp);
            }

          tmp = gfc_string_to_single_character (expr1se.string_length,
                                                expr1se.expr,
                                                code->expr1->ts.kind);
          case_num = gfc_create_var (ctype, "case_num");
          gfc_add_modify (&block, case_num, tmp);

          gfc_add_block_to_block (&block, &expr1se.post);

          tmp = gfc_finish_block (&body);
          tmp = build3_v (SWITCH_EXPR, case_num, tmp, NULL_TREE);
          gfc_add_expr_to_block (&block, tmp);

          tmp = build1_v (LABEL_EXPR, end_label);
          gfc_add_expr_to_block (&block, tmp);

          return gfc_finish_block (&block);
        }
    }

  if (code->expr1->ts.kind == 1)
    k = 0;
  else if (code->expr1->ts.kind == 4)
    k = 1;
  else
    gcc_unreachable ();

  if (select_struct[k] == NULL)
    {
      tree *chain = NULL;
      select_struct[k] = make_node (RECORD_TYPE);

      if (code->expr1->ts.kind == 1)
        TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char1");
      else if (code->expr1->ts.kind == 4)
        TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char4");
      else
        gcc_unreachable ();

#undef ADD_FIELD
#define ADD_FIELD(NAME, TYPE)                                               \
  ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k],                 \
                                          get_identifier (stringize(NAME)), \
                                          TYPE,                             \
                                          &chain)

      ADD_FIELD (string1, pchartype);
      ADD_FIELD (string1_len, gfc_charlen_type_node);

      ADD_FIELD (string2, pchartype);
      ADD_FIELD (string2_len, gfc_charlen_type_node);

      ADD_FIELD (target, integer_type_node);
#undef ADD_FIELD

      gfc_finish_type (select_struct[k]);
    }

  n = 0;
  for (d = cp; d; d = d->right)
    d->n = n++;

  for (c = code->block; c; c = c->block)
    {
      for (d = c->ext.block.case_list; d; d = d->next)
        {
          label = gfc_build_label_decl (NULL_TREE);
          tmp = build_case_label ((d->low == NULL && d->high == NULL)
                                  ? NULL
                                  : build_int_cst (integer_type_node, d->n),
                                  NULL, label);
          gfc_add_expr_to_block (&body, tmp);
        }

      tmp = gfc_trans_code (c->next);
      gfc_add_expr_to_block (&body, tmp);

      tmp = build1_v (GOTO_EXPR, end_label);
      gfc_add_expr_to_block (&body, tmp);
    }

  /* Generate the structure describing the branches */
  for (d = cp; d; d = d->right)
    {
      VEC(constructor_elt,gc) *node = NULL;

      gfc_init_se (&se, NULL);

      if (d->low == NULL)
        {
          CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], null_pointer_node);
          CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], integer_zero_node);
        }
      else
        {
          gfc_conv_expr_reference (&se, d->low);

          CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], se.expr);
          CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], se.string_length);
        }

      if (d->high == NULL)
        {
          CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], null_pointer_node);
          CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], integer_zero_node);
        }
      else
        {
          gfc_init_se (&se, NULL);
          gfc_conv_expr_reference (&se, d->high);

          CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], se.expr);
          CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], se.string_length);
        }

      CONSTRUCTOR_APPEND_ELT (node, ss_target[k],
                              build_int_cst (integer_type_node, d->n));

      tmp = build_constructor (select_struct[k], node);
      CONSTRUCTOR_APPEND_ELT (inits, NULL_TREE, tmp);
    }

  type = build_array_type (select_struct[k],
                           build_index_type (size_int (n-1)));

  init = build_constructor (type, inits);
  TREE_CONSTANT (init) = 1;
  TREE_STATIC (init) = 1;
  /* Create a static variable to hold the jump table.  */
  tmp = gfc_create_var (type, "jumptable");
  TREE_CONSTANT (tmp) = 1;
  TREE_STATIC (tmp) = 1;
  TREE_READONLY (tmp) = 1;
  DECL_INITIAL (tmp) = init;
  init = tmp;

  /* Build the library call */
  init = gfc_build_addr_expr (pvoid_type_node, init);

  if (code->expr1->ts.kind == 1)
    fndecl = gfor_fndecl_select_string;
  else if (code->expr1->ts.kind == 4)
    fndecl = gfor_fndecl_select_string_char4;
  else
    gcc_unreachable ();

  tmp = build_call_expr_loc (input_location,
                         fndecl, 4, init,
                         build_int_cst (gfc_charlen_type_node, n),
                         expr1se.expr, expr1se.string_length);
  case_num = gfc_create_var (integer_type_node, "case_num");
  gfc_add_modify (&block, case_num, tmp);

  gfc_add_block_to_block (&block, &expr1se.post);

  tmp = gfc_finish_block (&body);
  tmp = build3_v (SWITCH_EXPR, case_num, tmp, NULL_TREE);
  gfc_add_expr_to_block (&block, tmp);

  tmp = build1_v (LABEL_EXPR, end_label);
  gfc_add_expr_to_block (&block, tmp);

  return gfc_finish_block (&block);
}


/* Translate the three variants of the SELECT CASE construct.

   SELECT CASEs with INTEGER case expressions can be translated to an
   equivalent GENERIC switch statement, and for LOGICAL case
   expressions we build one or two if-else compares.

   SELECT CASEs with CHARACTER case expressions are a whole different
   story, because they don't exist in GENERIC.  So we sort them and
   do a binary search at runtime.

   Fortran has no BREAK statement, and it does not allow jumps from
   one case block to another.  That makes things a lot easier for
   the optimizers.  */

tree
gfc_trans_select (gfc_code * code)
{
  stmtblock_t block;
  tree body;
  tree exit_label;

  gcc_assert (code && code->expr1);
  gfc_init_block (&block);

  /* Build the exit label and hang it in.  */
  exit_label = gfc_build_label_decl (NULL_TREE);
  code->exit_label = exit_label;

  /* Empty SELECT constructs are legal.  */
  if (code->block == NULL)
    body = build_empty_stmt (input_location);

  /* Select the correct translation function.  */
  else
    switch (code->expr1->ts.type)
      {
      case BT_LOGICAL:
        body = gfc_trans_logical_select (code);
        break;

      case BT_INTEGER:
        body = gfc_trans_integer_select (code);
        break;

      case BT_CHARACTER:
        body = gfc_trans_character_select (code);
        break;

      default:
        gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
        /* Not reached */
      }

  /* Build everything together.  */
  gfc_add_expr_to_block (&block, body);
  gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label));

  return gfc_finish_block (&block);
}


/* Traversal function to substitute a replacement symtree if the symbol
   in the expression is the same as that passed.  f == 2 signals that
   that variable itself is not to be checked - only the references.
   This group of functions is used when the variable expression in a
   FORALL assignment has internal references.  For example:
                FORALL (i = 1:4) p(p(i)) = i
   The only recourse here is to store a copy of 'p' for the index
   expression.  */

static gfc_symtree *new_symtree;
static gfc_symtree *old_symtree;

static bool
forall_replace (gfc_expr *expr, gfc_symbol *sym, int *f)
{
  if (expr->expr_type != EXPR_VARIABLE)
    return false;

  if (*f == 2)
    *f = 1;
  else if (expr->symtree->n.sym == sym)
    expr->symtree = new_symtree;

  return false;
}

static void
forall_replace_symtree (gfc_expr *e, gfc_symbol *sym, int f)
{
  gfc_traverse_expr (e, sym, forall_replace, f);
}

static bool
forall_restore (gfc_expr *expr,
                gfc_symbol *sym ATTRIBUTE_UNUSED,
                int *f ATTRIBUTE_UNUSED)
{
  if (expr->expr_type != EXPR_VARIABLE)
    return false;

  if (expr->symtree == new_symtree)
    expr->symtree = old_symtree;

  return false;
}

static void
forall_restore_symtree (gfc_expr *e)
{
  gfc_traverse_expr (e, NULL, forall_restore, 0);
}

static void
forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
{
  gfc_se tse;
  gfc_se rse;
  gfc_expr *e;
  gfc_symbol *new_sym;
  gfc_symbol *old_sym;
  gfc_symtree *root;
  tree tmp;

  /* Build a copy of the lvalue.  */
  old_symtree = c->expr1->symtree;
  old_sym = old_symtree->n.sym;
  e = gfc_lval_expr_from_sym (old_sym);
  if (old_sym->attr.dimension)
    {
      gfc_init_se (&tse, NULL);
      gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN, false);
      gfc_add_block_to_block (pre, &tse.pre);
      gfc_add_block_to_block (post, &tse.post);
      tse.expr = build_fold_indirect_ref_loc (input_location, tse.expr);

      if (e->ts.type != BT_CHARACTER)
        {
          /* Use the variable offset for the temporary.  */
          tmp = gfc_conv_array_offset (old_sym->backend_decl);
          gfc_conv_descriptor_offset_set (pre, tse.expr, tmp);
        }
    }
  else
    {
      gfc_init_se (&tse, NULL);
      gfc_init_se (&rse, NULL);
      gfc_conv_expr (&rse, e);
      if (e->ts.type == BT_CHARACTER)
        {
          tse.string_length = rse.string_length;
          tmp = gfc_get_character_type_len (gfc_default_character_kind,
                                            tse.string_length);
          tse.expr = gfc_conv_string_tmp (&tse, build_pointer_type (tmp),
                                          rse.string_length);
          gfc_add_block_to_block (pre, &tse.pre);
          gfc_add_block_to_block (post, &tse.post);
        }
      else
        {
          tmp = gfc_typenode_for_spec (&e->ts);
          tse.expr = gfc_create_var (tmp, "temp");
        }

      tmp = gfc_trans_scalar_assign (&tse, &rse, e->ts, true,
                                     e->expr_type == EXPR_VARIABLE, true);
      gfc_add_expr_to_block (pre, tmp);
    }
  gfc_free_expr (e);

  /* Create a new symbol to represent the lvalue.  */
  new_sym = gfc_new_symbol (old_sym->name, NULL);
  new_sym->ts = old_sym->ts;
  new_sym->attr.referenced = 1;
  new_sym->attr.temporary = 1;
  new_sym->attr.dimension = old_sym->attr.dimension;
  new_sym->attr.flavor = old_sym->attr.flavor;

  /* Use the temporary as the backend_decl.  */
  new_sym->backend_decl = tse.expr;

  /* Create a fake symtree for it.  */
  root = NULL;
  new_symtree = gfc_new_symtree (&root, old_sym->name);
  new_symtree->n.sym = new_sym;
  gcc_assert (new_symtree == root);

  /* Go through the expression reference replacing the old_symtree
     with the new.  */
  forall_replace_symtree (c->expr1, old_sym, 2);

  /* Now we have made this temporary, we might as well use it for
  the right hand side.  */
  forall_replace_symtree (c->expr2, old_sym, 1);
}


/* Handles dependencies in forall assignments.  */
static int
check_forall_dependencies (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
{
  gfc_ref *lref;
  gfc_ref *rref;
  int need_temp;
  gfc_symbol *lsym;

  lsym = c->expr1->symtree->n.sym;
  need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);

  /* Now check for dependencies within the 'variable'
     expression itself.  These are treated by making a complete
     copy of variable and changing all the references to it
     point to the copy instead.  Note that the shallow copy of
     the variable will not suffice for derived types with
     pointer components.  We therefore leave these to their
     own devices.  */
  if (lsym->ts.type == BT_DERIVED
        && lsym->ts.u.derived->attr.pointer_comp)
    return need_temp;

  new_symtree = NULL;
  if (find_forall_index (c->expr1, lsym, 2) == SUCCESS)
    {
      forall_make_variable_temp (c, pre, post);
      need_temp = 0;
    }

  /* Substrings with dependencies are treated in the same
     way.  */
  if (c->expr1->ts.type == BT_CHARACTER
        && c->expr1->ref
        && c->expr2->expr_type == EXPR_VARIABLE
        && lsym == c->expr2->symtree->n.sym)
    {
      for (lref = c->expr1->ref; lref; lref = lref->next)
        if (lref->type == REF_SUBSTRING)
          break;
      for (rref = c->expr2->ref; rref; rref = rref->next)
        if (rref->type == REF_SUBSTRING)
          break;

      if (rref && lref
            && gfc_dep_compare_expr (rref->u.ss.start, lref->u.ss.start) < 0)
        {
          forall_make_variable_temp (c, pre, post);
          need_temp = 0;
        }
    }
  return need_temp;
}


static void
cleanup_forall_symtrees (gfc_code *c)
{
  forall_restore_symtree (c->expr1);
  forall_restore_symtree (c->expr2);
  free (new_symtree->n.sym);
  free (new_symtree);
}


/* Generate the loops for a FORALL block, specified by FORALL_TMP.  BODY
   is the contents of the FORALL block/stmt to be iterated.  MASK_FLAG
   indicates whether we should generate code to test the FORALLs mask
   array.  OUTER is the loop header to be used for initializing mask
   indices.

   The generated loop format is:
    count = (end - start + step) / step
    loopvar = start
    while (1)
      {
        if (count <=0 )
          goto end_of_loop
        <body>
        loopvar += step
        count --
      }
    end_of_loop:  */

static tree
gfc_trans_forall_loop (forall_info *forall_tmp, tree body,
                       int mask_flag, stmtblock_t *outer)
{
  int n, nvar;
  tree tmp;
  tree cond;
  stmtblock_t block;
  tree exit_label;
  tree count;
  tree var, start, end, step;
  iter_info *iter;

  /* Initialize the mask index outside the FORALL nest.  */
  if (mask_flag && forall_tmp->mask)
    gfc_add_modify (outer, forall_tmp->maskindex, gfc_index_zero_node);

  iter = forall_tmp->this_loop;
  nvar = forall_tmp->nvar;
  for (n = 0; n < nvar; n++)
    {
      var = iter->var;
      start = iter->start;
      end = iter->end;
      step = iter->step;

      exit_label = gfc_build_label_decl (NULL_TREE);
      TREE_USED (exit_label) = 1;

      /* The loop counter.  */
      count = gfc_create_var (TREE_TYPE (var), "count");

      /* The body of the loop.  */
      gfc_init_block (&block);

      /* The exit condition.  */
      cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
                              count, build_int_cst (TREE_TYPE (count), 0));
      tmp = build1_v (GOTO_EXPR, exit_label);
      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
                             cond, tmp, build_empty_stmt (input_location));
      gfc_add_expr_to_block (&block, tmp);

      /* The main loop body.  */
      gfc_add_expr_to_block (&block, body);

      /* Increment the loop variable.  */
      tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var,
                             step);
      gfc_add_modify (&block, var, tmp);

      /* Advance to the next mask element.  Only do this for the
         innermost loop.  */
      if (n == 0 && mask_flag && forall_tmp->mask)
        {
          tree maskindex = forall_tmp->maskindex;
          tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
                                 maskindex, gfc_index_one_node);
          gfc_add_modify (&block, maskindex, tmp);
        }

      /* Decrement the loop counter.  */
      tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), count,
                             build_int_cst (TREE_TYPE (var), 1));
      gfc_add_modify (&block, count, tmp);

      body = gfc_finish_block (&block);

      /* Loop var initialization.  */
      gfc_init_block (&block);
      gfc_add_modify (&block, var, start);


      /* Initialize the loop counter.  */
      tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), step,
                             start);
      tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), end,
                             tmp);
      tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (var),
                             tmp, step);
      gfc_add_modify (&block, count, tmp);

      /* The loop expression.  */
      tmp = build1_v (LOOP_EXPR, body);
      gfc_add_expr_to_block (&block, tmp);

      /* The exit label.  */
      tmp = build1_v (LABEL_EXPR, exit_label);
      gfc_add_expr_to_block (&block, tmp);

      body = gfc_finish_block (&block);
      iter = iter->next;
    }
  return body;
}


/* Generate the body and loops according to MASK_FLAG.  If MASK_FLAG
   is nonzero, the body is controlled by all masks in the forall nest.
   Otherwise, the innermost loop is not controlled by it's mask.  This
   is used for initializing that mask.  */

static tree
gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body,
                              int mask_flag)
{
  tree tmp;
  stmtblock_t header;
  forall_info *forall_tmp;
  tree mask, maskindex;

  gfc_start_block (&header);

  forall_tmp = nested_forall_info;
  while (forall_tmp != NULL)
    {
      /* Generate body with masks' control.  */
      if (mask_flag)
        {
          mask = forall_tmp->mask;
          maskindex = forall_tmp->maskindex;

          /* If a mask was specified make the assignment conditional.  */
          if (mask)
            {
              tmp = gfc_build_array_ref (mask, maskindex, NULL);
              body = build3_v (COND_EXPR, tmp, body,
                               build_empty_stmt (input_location));
            }
        }
      body = gfc_trans_forall_loop (forall_tmp, body, mask_flag, &header);
      forall_tmp = forall_tmp->prev_nest;
      mask_flag = 1;
    }

  gfc_add_expr_to_block (&header, body);
  return gfc_finish_block (&header);
}


/* Allocate data for holding a temporary array.  Returns either a local
   temporary array or a pointer variable.  */

static tree
gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock,
                 tree elem_type)
{
  tree tmpvar;
  tree type;
  tree tmp;

  if (INTEGER_CST_P (size))
    tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
                           size, gfc_index_one_node);
  else
    tmp = NULL_TREE;

  type = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
  type = build_array_type (elem_type, type);
  if (gfc_can_put_var_on_stack (bytesize))
    {
      gcc_assert (INTEGER_CST_P (size));
      tmpvar = gfc_create_var (type, "temp");
      *pdata = NULL_TREE;
    }
  else
    {
      tmpvar = gfc_create_var (build_pointer_type (type), "temp");
      *pdata = convert (pvoid_type_node, tmpvar);

      tmp = gfc_call_malloc (pblock, TREE_TYPE (tmpvar), bytesize);
      gfc_add_modify (pblock, tmpvar, tmp);
    }
  return tmpvar;
}


/* Generate codes to copy the temporary to the actual lhs.  */

static tree
generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
                               tree count1, tree wheremask, bool invert)
{
  gfc_ss *lss;
  gfc_se lse, rse;
  stmtblock_t block, body;
  gfc_loopinfo loop1;
  tree tmp;
  tree wheremaskexpr;

  /* Walk the lhs.  */
  lss = gfc_walk_expr (expr);

  if (lss == gfc_ss_terminator)
    {
      gfc_start_block (&block);

      gfc_init_se (&lse, NULL);

      /* Translate the expression.  */
      gfc_conv_expr (&lse, expr);

      /* Form the expression for the temporary.  */
      tmp = gfc_build_array_ref (tmp1, count1, NULL);

      /* Use the scalar assignment as is.  */
      gfc_add_block_to_block (&block, &lse.pre);
      gfc_add_modify (&block, lse.expr, tmp);
      gfc_add_block_to_block (&block, &lse.post);

      /* Increment the count1.  */
      tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
                             count1, gfc_index_one_node);
      gfc_add_modify (&block, count1, tmp);

      tmp = gfc_finish_block (&block);
    }
  else
    {
      gfc_start_block (&block);

      gfc_init_loopinfo (&loop1);
      gfc_init_se (&rse, NULL);
      gfc_init_se (&lse, NULL);

      /* Associate the lss with the loop.  */
      gfc_add_ss_to_loop (&loop1, lss);

      /* Calculate the bounds of the scalarization.  */
      gfc_conv_ss_startstride (&loop1);
      /* Setup the scalarizing loops.  */
      gfc_conv_loop_setup (&loop1, &expr->where);

      gfc_mark_ss_chain_used (lss, 1);

      /* Start the scalarized loop body.  */
      gfc_start_scalarized_body (&loop1, &body);

      /* Setup the gfc_se structures.  */
      gfc_copy_loopinfo_to_se (&lse, &loop1);
      lse.ss = lss;

      /* Form the expression of the temporary.  */
      if (lss != gfc_ss_terminator)
        rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
      /* Translate expr.  */
      gfc_conv_expr (&lse, expr);

      /* Use the scalar assignment.  */
      rse.string_length = lse.string_length;
      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true, true);

      /* Form the mask expression according to the mask tree list.  */
      if (wheremask)
        {
          wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
          if (invert)
            wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
                                             TREE_TYPE (wheremaskexpr),
                                             wheremaskexpr);
          tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
                                 wheremaskexpr, tmp,
                                 build_empty_stmt (input_location));
       }

      gfc_add_expr_to_block (&body, tmp);

      /* Increment count1.  */
      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
                             count1, gfc_index_one_node);
      gfc_add_modify (&body, count1, tmp);

      /* Increment count3.  */
      if (count3)
        {
          tmp = fold_build2_loc (input_location, PLUS_EXPR,
                                 gfc_array_index_type, count3,
                                 gfc_index_one_node);
          gfc_add_modify (&body, count3, tmp);
        }

      /* Generate the copying loops.  */
      gfc_trans_scalarizing_loops (&loop1, &body);
      gfc_add_block_to_block (&block, &loop1.pre);
      gfc_add_block_to_block (&block, &loop1.post);
      gfc_cleanup_loop (&loop1);

      tmp = gfc_finish_block (&block);
    }
  return tmp;
}


/* Generate codes to copy rhs to the temporary. TMP1 is the address of
   temporary, LSS and RSS are formed in function compute_inner_temp_size(),
   and should not be freed.  WHEREMASK is the conditional execution mask
   whose sense may be inverted by INVERT.  */

static tree
generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
                               tree count1, gfc_ss *lss, gfc_ss *rss,
                               tree wheremask, bool invert)
{
  stmtblock_t block, body1;
  gfc_loopinfo loop;
  gfc_se lse;
  gfc_se rse;
  tree tmp;
  tree wheremaskexpr;

  gfc_start_block (&block);

  gfc_init_se (&rse, NULL);
  gfc_init_se (&lse, NULL);

  if (lss == gfc_ss_terminator)
    {
      gfc_init_block (&body1);
      gfc_conv_expr (&rse, expr2);
      lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
    }
  else
    {
      /* Initialize the loop.  */
      gfc_init_loopinfo (&loop);

      /* We may need LSS to determine the shape of the expression.  */
      gfc_add_ss_to_loop (&loop, lss);
      gfc_add_ss_to_loop (&loop, rss);

      gfc_conv_ss_startstride (&loop);
      gfc_conv_loop_setup (&loop, &expr2->where);

      gfc_mark_ss_chain_used (rss, 1);
      /* Start the loop body.  */
      gfc_start_scalarized_body (&loop, &body1);

      /* Translate the expression.  */
      gfc_copy_loopinfo_to_se (&rse, &loop);
      rse.ss = rss;
      gfc_conv_expr (&rse, expr2);

      /* Form the expression of the temporary.  */
      lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
    }

  /* Use the scalar assignment.  */
  lse.string_length = rse.string_length;
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, true,
                                 expr2->expr_type == EXPR_VARIABLE, true);

  /* Form the mask expression according to the mask tree list.  */
  if (wheremask)
    {
      wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
      if (invert)
        wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
                                         TREE_TYPE (wheremaskexpr),
                                         wheremaskexpr);
      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
                             wheremaskexpr, tmp,
                             build_empty_stmt (input_location));
    }

  gfc_add_expr_to_block (&body1, tmp);

  if (lss == gfc_ss_terminator)
    {
      gfc_add_block_to_block (&block, &body1);

      /* Increment count1.  */
      tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
                             count1, gfc_index_one_node);
      gfc_add_modify (&block, count1, tmp);
    }
  else
    {
      /* Increment count1.  */
      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
                             count1, gfc_index_one_node);
      gfc_add_modify (&body1, count1, tmp);

      /* Increment count3.  */
      if (count3)
        {
          tmp = fold_build2_loc (input_location, PLUS_EXPR,
                                 gfc_array_index_type,
                                 count3, gfc_index_one_node);
          gfc_add_modify (&body1, count3, tmp);
        }

      /* Generate the copying loops.  */
      gfc_trans_scalarizing_loops (&loop, &body1);

      gfc_add_block_to_block (&block, &loop.pre);
      gfc_add_block_to_block (&block, &loop.post);

      gfc_cleanup_loop (&loop);
      /* TODO: Reuse lss and rss when copying temp->lhs.  Need to be careful
         as tree nodes in SS may not be valid in different scope.  */
    }

  tmp = gfc_finish_block (&block);
  return tmp;
}


/* Calculate the size of temporary needed in the assignment inside forall.
   LSS and RSS are filled in this function.  */

static tree
compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2,
                         stmtblock_t * pblock,
                         gfc_ss **lss, gfc_ss **rss)
{
  gfc_loopinfo loop;
  tree size;
  int i;
  int save_flag;
  tree tmp;

  *lss = gfc_walk_expr (expr1);
  *rss = NULL;

  size = gfc_index_one_node;
  if (*lss != gfc_ss_terminator)
    {
      gfc_init_loopinfo (&loop);

      /* Walk the RHS of the expression.  */
      *rss = gfc_walk_expr (expr2);
      if (*rss == gfc_ss_terminator)
        /* The rhs is scalar.  Add a ss for the expression.  */
        *rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);

      /* Associate the SS with the loop.  */
      gfc_add_ss_to_loop (&loop, *lss);
      /* We don't actually need to add the rhs at this point, but it might
         make guessing the loop bounds a bit easier.  */
      gfc_add_ss_to_loop (&loop, *rss);

      /* We only want the shape of the expression, not rest of the junk
         generated by the scalarizer.  */
      loop.array_parameter = 1;

      /* Calculate the bounds of the scalarization.  */
      save_flag = gfc_option.rtcheck;
      gfc_option.rtcheck &= !GFC_RTCHECK_BOUNDS;
      gfc_conv_ss_startstride (&loop);
      gfc_option.rtcheck = save_flag;
      gfc_conv_loop_setup (&loop, &expr2->where);

      /* Figure out how many elements we need.  */
      for (i = 0; i < loop.dimen; i++)
        {
          tmp = fold_build2_loc (input_location, MINUS_EXPR,
                                 gfc_array_index_type,
                                 gfc_index_one_node, loop.from[i]);
          tmp = fold_build2_loc (input_location, PLUS_EXPR,
                                 gfc_array_index_type, tmp, loop.to[i]);
          size = fold_build2_loc (input_location, MULT_EXPR,
                                  gfc_array_index_type, size, tmp);
        }
      gfc_add_block_to_block (pblock, &loop.pre);
      size = gfc_evaluate_now (size, pblock);
      gfc_add_block_to_block (pblock, &loop.post);

      /* TODO: write a function that cleans up a loopinfo without freeing
         the SS chains.  Currently a NOP.  */
    }

  return size;
}


/* Calculate the overall iterator number of the nested forall construct.
   This routine actually calculates the number of times the body of the
   nested forall specified by NESTED_FORALL_INFO is executed and multiplies
   that by the expression INNER_SIZE.  The BLOCK argument specifies the
   block in which to calculate the result, and the optional INNER_SIZE_BODY
   argument contains any statements that need to executed (inside the loop)
   to initialize or calculate INNER_SIZE.  */

static tree
compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size,
                             stmtblock_t *inner_size_body, stmtblock_t *block)
{
  forall_info *forall_tmp = nested_forall_info;
  tree tmp, number;
  stmtblock_t body;

  /* We can eliminate the innermost unconditional loops with constant
     array bounds.  */
  if (INTEGER_CST_P (inner_size))
    {
      while (forall_tmp
             && !forall_tmp->mask 
             && INTEGER_CST_P (forall_tmp->size))
        {
          inner_size = fold_build2_loc (input_location, MULT_EXPR,
                                        gfc_array_index_type,
                                        inner_size, forall_tmp->size);
          forall_tmp = forall_tmp->prev_nest;
        }

      /* If there are no loops left, we have our constant result.  */
      if (!forall_tmp)
        return inner_size;
    }

  /* Otherwise, create a temporary variable to compute the result.  */
  number = gfc_create_var (gfc_array_index_type, "num");
  gfc_add_modify (block, number, gfc_index_zero_node);

  gfc_start_block (&body);
  if (inner_size_body)
    gfc_add_block_to_block (&body, inner_size_body);
  if (forall_tmp)
    tmp = fold_build2_loc (input_location, PLUS_EXPR,
                           gfc_array_index_type, number, inner_size);
  else
    tmp = inner_size;
  gfc_add_modify (&body, number, tmp);
  tmp = gfc_finish_block (&body);

  /* Generate loops.  */
  if (forall_tmp != NULL)
    tmp = gfc_trans_nested_forall_loop (forall_tmp, tmp, 1);

  gfc_add_expr_to_block (block, tmp);

  return number;
}


/* Allocate temporary for forall construct.  SIZE is the size of temporary
   needed.  PTEMP1 is returned for space free.  */

static tree
allocate_temp_for_forall_nest_1 (tree type, tree size, stmtblock_t * block,
                                 tree * ptemp1)
{
  tree bytesize;
  tree unit;
  tree tmp;

  unit = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (type));
  if (!integer_onep (unit))
    bytesize = fold_build2_loc (input_location, MULT_EXPR,
                                gfc_array_index_type, size, unit);
  else
    bytesize = size;

  *ptemp1 = NULL;
  tmp = gfc_do_allocate (bytesize, size, ptemp1, block, type);

  if (*ptemp1)
    tmp = build_fold_indirect_ref_loc (input_location, tmp);
  return tmp;
}


/* Allocate temporary for forall construct according to the information in
   nested_forall_info.  INNER_SIZE is the size of temporary needed in the
   assignment inside forall.  PTEMP1 is returned for space free.  */

static tree
allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type,
                               tree inner_size, stmtblock_t * inner_size_body,
                               stmtblock_t * block, tree * ptemp1)
{
  tree size;

  /* Calculate the total size of temporary needed in forall construct.  */
  size = compute_overall_iter_number (nested_forall_info, inner_size,
                                      inner_size_body, block);

  return allocate_temp_for_forall_nest_1 (type, size, block, ptemp1);
}


/* Handle assignments inside forall which need temporary.

    forall (i=start:end:stride; maskexpr)
      e<i> = f<i>
    end forall
   (where e,f<i> are arbitrary expressions possibly involving i
    and there is a dependency between e<i> and f<i>)
   Translates to:
    masktmp(:) = maskexpr(:)

    maskindex = 0;
    count1 = 0;
    num = 0;
    for (i = start; i <= end; i += stride)
      num += SIZE (f<i>)
    count1 = 0;
    ALLOCATE (tmp(num))
    for (i = start; i <= end; i += stride)
      {
        if (masktmp[maskindex++])
          tmp[count1++] = f<i>
      }
    maskindex = 0;
    count1 = 0;
    for (i = start; i <= end; i += stride)
      {
        if (masktmp[maskindex++])
          e<i> = tmp[count1++]
      }
    DEALLOCATE (tmp)
  */
static void
gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
                            tree wheremask, bool invert,
                            forall_info * nested_forall_info,
                            stmtblock_t * block)
{
  tree type;
  tree inner_size;
  gfc_ss *lss, *rss;
  tree count, count1;
  tree tmp, tmp1;
  tree ptemp1;
  stmtblock_t inner_size_body;

  /* Create vars. count1 is the current iterator number of the nested
     forall.  */
  count1 = gfc_create_var (gfc_array_index_type, "count1");

  /* Count is the wheremask index.  */
  if (wheremask)
    {
      count = gfc_create_var (gfc_array_index_type, "count");
      gfc_add_modify (block, count, gfc_index_zero_node);
    }
  else
    count = NULL;

  /* Initialize count1.  */
  gfc_add_modify (block, count1, gfc_index_zero_node);

  /* Calculate the size of temporary needed in the assignment. Return loop, lss
     and rss which are used in function generate_loop_for_rhs_to_temp().  */
  gfc_init_block (&inner_size_body);
  inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
                                        &lss, &rss);

  /* The type of LHS. Used in function allocate_temp_for_forall_nest */
  if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->length)
    {
      if (!expr1->ts.u.cl->backend_decl)
        {
          gfc_se tse;
          gfc_init_se (&tse, NULL);
          gfc_conv_expr (&tse, expr1->ts.u.cl->length);
          expr1->ts.u.cl->backend_decl = tse.expr;
        }
      type = gfc_get_character_type_len (gfc_default_character_kind,
                                         expr1->ts.u.cl->backend_decl);
    }
  else
    type = gfc_typenode_for_spec (&expr1->ts);

  /* Allocate temporary for nested forall construct according to the
     information in nested_forall_info and inner_size.  */
  tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size,
                                        &inner_size_body, block, &ptemp1);

  /* Generate codes to copy rhs to the temporary .  */
  tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss,
                                       wheremask, invert);

  /* Generate body and loops according to the information in
     nested_forall_info.  */
  tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
  gfc_add_expr_to_block (block, tmp);

  /* Reset count1.  */
  gfc_add_modify (block, count1, gfc_index_zero_node);

  /* Reset count.  */
  if (wheremask)
    gfc_add_modify (block, count, gfc_index_zero_node);

  /* Generate codes to copy the temporary to lhs.  */
  tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1,
                                       wheremask, invert);

  /* Generate body and loops according to the information in
     nested_forall_info.  */
  tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
  gfc_add_expr_to_block (block, tmp);

  if (ptemp1)
    {
      /* Free the temporary.  */
      tmp = gfc_call_free (ptemp1);
      gfc_add_expr_to_block (block, tmp);
    }
}


/* Translate pointer assignment inside FORALL which need temporary.  */

static void
gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
                                    forall_info * nested_forall_info,
                                    stmtblock_t * block)
{
  tree type;
  tree inner_size;
  gfc_ss *lss, *rss;
  gfc_se lse;
  gfc_se rse;
  gfc_array_info *info;
  gfc_loopinfo loop;
  tree desc;
  tree parm;
  tree parmtype;
  stmtblock_t body;
  tree count;
  tree tmp, tmp1, ptemp1;

  count = gfc_create_var (gfc_array_index_type, "count");
  gfc_add_modify (block, count, gfc_index_zero_node);

  inner_size = gfc_index_one_node;
  lss = gfc_walk_expr (expr1);
  rss = gfc_walk_expr (expr2);
  if (lss == gfc_ss_terminator)
    {
      type = gfc_typenode_for_spec (&expr1->ts);
      type = build_pointer_type (type);

      /* Allocate temporary for nested forall construct according to the
         information in nested_forall_info and inner_size.  */
      tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type,
                                            inner_size, NULL, block, &ptemp1);
      gfc_start_block (&body);
      gfc_init_se (&lse, NULL);
      lse.expr = gfc_build_array_ref (tmp1, count, NULL);
      gfc_init_se (&rse, NULL);
      rse.want_pointer = 1;
      gfc_conv_expr (&rse, expr2);
      gfc_add_block_to_block (&body, &rse.pre);
      gfc_add_modify (&body, lse.expr,
                           fold_convert (TREE_TYPE (lse.expr), rse.expr));
      gfc_add_block_to_block (&body, &rse.post);

      /* Increment count.  */
      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
                             count, gfc_index_one_node);
      gfc_add_modify (&body, count, tmp);

      tmp = gfc_finish_block (&body);

      /* Generate body and loops according to the information in
         nested_forall_info.  */
      tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
      gfc_add_expr_to_block (block, tmp);

      /* Reset count.  */
      gfc_add_modify (block, count, gfc_index_zero_node);

      gfc_start_block (&body);
      gfc_init_se (&lse, NULL);
      gfc_init_se (&rse, NULL);
      rse.expr = gfc_build_array_ref (tmp1, count, NULL);
      lse.want_pointer = 1;
      gfc_conv_expr (&lse, expr1);
      gfc_add_block_to_block (&body, &lse.pre);
      gfc_add_modify (&body, lse.expr, rse.expr);
      gfc_add_block_to_block (&body, &lse.post);
      /* Increment count.  */
      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
                             count, gfc_index_one_node);
      gfc_add_modify (&body, count, tmp);
      tmp = gfc_finish_block (&body);

      /* Generate body and loops according to the information in
         nested_forall_info.  */
      tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
      gfc_add_expr_to_block (block, tmp);
    }
  else
    {
      gfc_init_loopinfo (&loop);