static void
genericize_if_stmt (tree *stmt_p)
{
  tree stmt, cond, then_, else_;
  location_t locus = EXPR_LOCATION (*stmt_p);

  stmt = *stmt_p;
  cond = IF_COND (stmt);
  then_ = THEN_CLAUSE (stmt);
  else_ = ELSE_CLAUSE (stmt);

  if (!then_)
    then_ = build_empty_stmt ();
  if (!else_)
    else_ = build_empty_stmt ();

  if (integer_nonzerop (cond) && !TREE_SIDE_EFFECTS (else_))
    stmt = then_;
  else if (integer_zerop (cond) && !TREE_SIDE_EFFECTS (then_))
    stmt = else_;
  else
    stmt = build3 (COND_EXPR, void_type_node, cond, then_, else_);
  if (CAN_HAVE_LOCATION_P (stmt) && !EXPR_HAS_LOCATION (stmt))
    SET_EXPR_LOCATION (stmt, locus);
  *stmt_p = stmt;
}

/* Reallocate MEM so it has SIZE bytes of data.  This behaves like the
   following pseudo-code:

void *
internal_realloc (void *mem, size_t size)
{
  if (size < 0)
    runtime_error ("Attempt to allocate a negative amount of memory.");
  res = realloc (mem, size);
  if (!res && size != 0)
    _gfortran_os_error ("Out of memory");

  if (size == 0)
    return NULL;

  return res;
}  */
tree
gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
{
  tree msg, res, negative, nonzero, zero, null_result, tmp;
  tree type = TREE_TYPE (mem);

  size = gfc_evaluate_now (size, block);

  if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
    size = fold_convert (size_type_node, size);

  /* Create a variable to hold the result.  */
  res = gfc_create_var (type, NULL);

  /* size < 0 ?  */
  negative = fold_build2 (LT_EXPR, boolean_type_node, size,
			  build_int_cst (size_type_node, 0));
  msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
      ("Attempt to allocate a negative amount of memory."));
  tmp = fold_build3 (COND_EXPR, void_type_node, negative,
		     build_call_expr_loc (input_location,
				      gfor_fndecl_runtime_error, 1, msg),
		     build_empty_stmt (input_location));
  gfc_add_expr_to_block (block, tmp);

  /* Call realloc and check the result.  */
  tmp = build_call_expr_loc (input_location,
			 built_in_decls[BUILT_IN_REALLOC], 2,
			 fold_convert (pvoid_type_node, mem), size);
  gfc_add_modify (block, res, fold_convert (type, tmp));
  null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
			     build_int_cst (pvoid_type_node, 0));
  nonzero = fold_build2 (NE_EXPR, boolean_type_node, size,
			 build_int_cst (size_type_node, 0));
  null_result = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, null_result,
			     nonzero);
  msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
						("Out of memory"));
  tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
		     build_call_expr_loc (input_location,
				      gfor_fndecl_os_error, 1, msg),
		     build_empty_stmt (input_location));
  gfc_add_expr_to_block (block, tmp);

  /* if (size == 0) then the result is NULL.  */
  tmp = fold_build2 (MODIFY_EXPR, type, res, build_int_cst (type, 0));
  zero = fold_build1 (TRUTH_NOT_EXPR, boolean_type_node, nonzero);
  tmp = fold_build3 (COND_EXPR, void_type_node, zero, tmp,
		     build_empty_stmt (input_location));
  gfc_add_expr_to_block (block, tmp);

  return res;
}

tree
create_cilk_function_exit (tree frame, bool detaches, bool needs_sync)
{
  tree epi = alloc_stmt_list ();

  if (needs_sync) 
    append_to_statement_list (build_cilk_sync (), &epi);
  tree func_ptr = build1 (ADDR_EXPR, cilk_frame_ptr_type_decl, frame);
  tree pop_frame = build_call_expr (cilk_pop_fndecl, 1, func_ptr);
  tree worker = cilk_dot (frame, CILK_TI_FRAME_WORKER, 0);
  tree current = cilk_arrow (worker, CILK_TI_WORKER_CUR, 0);
  tree parent = cilk_dot (frame, CILK_TI_FRAME_PARENT, 0);
  tree set_current = build2 (MODIFY_EXPR, void_type_node, current, parent);
  append_to_statement_list (set_current, &epi);
  append_to_statement_list (pop_frame, &epi);
  tree call = build_call_expr (cilk_leave_fndecl, 1, func_ptr);
  if (!detaches)
    {
      tree flags = cilk_dot (frame, CILK_TI_FRAME_FLAGS, false);
      tree flags_cmp_expr = fold_build2 (NE_EXPR, TREE_TYPE (flags), flags, 
					 build_int_cst (TREE_TYPE (flags), 
							CILK_FRAME_VERSION));
      call = fold_build3 (COND_EXPR, void_type_node, flags_cmp_expr,
			  call, build_empty_stmt (EXPR_LOCATION (flags)));
    }
  append_to_statement_list (call, &epi);  
  return epi;
}

tree
c_build_bind_expr (tree block, tree body)
{
  tree decls, bind;

  if (block == NULL_TREE)
    decls = NULL_TREE;
  else if (TREE_CODE (block) == BLOCK)
    decls = BLOCK_VARS (block);
  else
    {
      decls = block;
      if (DECL_ARTIFICIAL (decls))
        block = NULL_TREE;
      else
        {
          block = make_node (BLOCK);
          BLOCK_VARS (block) = decls;
          add_block_to_enclosing (block);
        }
    }

  if (!body)
    body = build_empty_stmt ();
  if (decls || block)
    {
      bind = build3 (BIND_EXPR, void_type_node, decls, body, block);
      TREE_SIDE_EFFECTS (bind) = 1;
    }
  else
    bind = body;

  return bind;
}

void
gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
			 locus * where, const char * msgid, ...)
{
  va_list ap;
  stmtblock_t block;
  tree body;
  tree tmp;
  tree tmpvar = NULL;

  if (integer_zerop (cond))
    return;

  if (once)
    {
       tmpvar = gfc_create_var (boolean_type_node, "print_warning");
       TREE_STATIC (tmpvar) = 1;
       DECL_INITIAL (tmpvar) = boolean_true_node;
       gfc_add_expr_to_block (pblock, tmpvar);
    }

  gfc_start_block (&block);

  /* The code to generate the error.  */
  va_start (ap, msgid);
  gfc_add_expr_to_block (&block,
			 trans_runtime_error_vararg (error, where,
						     msgid, ap));

  if (once)
    gfc_add_modify (&block, tmpvar, boolean_false_node);

  body = gfc_finish_block (&block);

  if (integer_onep (cond))
    {
      gfc_add_expr_to_block (pblock, body);
    }
  else
    {
      /* Tell the compiler that this isn't likely.  */
      if (once)
	cond = fold_build2_loc (where->lb->location, TRUTH_AND_EXPR,
				long_integer_type_node, tmpvar, cond);
      else
	cond = fold_convert (long_integer_type_node, cond);

      tmp = build_int_cst (long_integer_type_node, 0);
      cond = build_call_expr_loc (where->lb->location,
			      built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
      cond = fold_convert (boolean_type_node, cond);

      tmp = fold_build3_loc (where->lb->location, COND_EXPR, void_type_node,
			     cond, body,
			     build_empty_stmt (where->lb->location));
      gfc_add_expr_to_block (pblock, tmp);
    }
}

/* Reallocate MEM so it has SIZE bytes of data.  This behaves like the
   following pseudo-code:

void *
internal_realloc (void *mem, size_t size)
{
  res = realloc (mem, size);
  if (!res && size != 0)
    _gfortran_os_error ("Allocation would exceed memory limit");

  if (size == 0)
    return NULL;

  return res;
}  */
tree
gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
{
  tree msg, res, nonzero, zero, null_result, tmp;
  tree type = TREE_TYPE (mem);

  size = gfc_evaluate_now (size, block);

  if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
    size = fold_convert (size_type_node, size);

  /* Create a variable to hold the result.  */
  res = gfc_create_var (type, NULL);

  /* Call realloc and check the result.  */
  tmp = build_call_expr_loc (input_location,
			 builtin_decl_explicit (BUILT_IN_REALLOC), 2,
			 fold_convert (pvoid_type_node, mem), size);
  gfc_add_modify (block, res, fold_convert (type, tmp));
  null_result = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
				 res, build_int_cst (pvoid_type_node, 0));
  nonzero = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, size,
			     build_int_cst (size_type_node, 0));
  null_result = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
				 null_result, nonzero);
  msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
			     ("Allocation would exceed memory limit"));
  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
			 null_result,
			 build_call_expr_loc (input_location,
					      gfor_fndecl_os_error, 1, msg),
			 build_empty_stmt (input_location));
  gfc_add_expr_to_block (block, tmp);

  /* if (size == 0) then the result is NULL.  */
  tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, res,
			 build_int_cst (type, 0));
  zero = fold_build1_loc (input_location, TRUTH_NOT_EXPR, boolean_type_node,
			  nonzero);
  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, zero, tmp,
			 build_empty_stmt (input_location));
  gfc_add_expr_to_block (block, tmp);

  return res;
}

static void
gimplify_if_stmt (tree *stmt_p)
{
  tree stmt, cond, then_, else_;

  stmt = *stmt_p;
  cond = IF_COND (stmt);
  then_ = THEN_CLAUSE (stmt);
  else_ = ELSE_CLAUSE (stmt);

  if (!then_)
    then_ = build_empty_stmt ();
  if (!else_)
    else_ = build_empty_stmt ();

  if (integer_nonzerop (cond) && !TREE_SIDE_EFFECTS (else_))
    stmt = then_;
  else if (integer_zerop (cond) && !TREE_SIDE_EFFECTS (then_))
    stmt = else_;
  else
    stmt = build3 (COND_EXPR, void_type_node, cond, then_, else_);
  *stmt_p = stmt;
}

/* Call malloc to allocate size bytes of memory, with special conditions:
      + if size == 0, return a malloced area of size 1,
      + if malloc returns NULL, issue a runtime error.  */
tree
gfc_call_malloc (stmtblock_t * block, tree type, tree size)
{
  tree tmp, msg, malloc_result, null_result, res, malloc_tree;
  stmtblock_t block2;

  size = gfc_evaluate_now (size, block);

  if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
    size = fold_convert (size_type_node, size);

  /* Create a variable to hold the result.  */
  res = gfc_create_var (prvoid_type_node, NULL);

  /* Call malloc.  */
  gfc_start_block (&block2);

  size = fold_build2_loc (input_location, MAX_EXPR, size_type_node, size,
			  build_int_cst (size_type_node, 1));

  malloc_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
  gfc_add_modify (&block2, res,
		  fold_convert (prvoid_type_node,
				build_call_expr_loc (input_location,
						     malloc_tree, 1, size)));

  /* Optionally check whether malloc was successful.  */
  if (gfc_option.rtcheck & GFC_RTCHECK_MEM)
    {
      null_result = fold_build2_loc (input_location, EQ_EXPR,
				     boolean_type_node, res,
				     build_int_cst (pvoid_type_node, 0));
      msg = gfc_build_addr_expr (pchar_type_node,
	      gfc_build_localized_cstring_const ("Memory allocation failed"));
      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
			     null_result,
	      build_call_expr_loc (input_location,
				   gfor_fndecl_os_error, 1, msg),
				   build_empty_stmt (input_location));
      gfc_add_expr_to_block (&block2, tmp);
    }

  malloc_result = gfc_finish_block (&block2);

  gfc_add_expr_to_block (block, malloc_result);

  if (type != NULL)
    res = fold_convert (type, res);
  return res;
}

/* Allocate memory, using an optional status argument.
 
   This function follows the following pseudo-code:

    void *
    allocate (size_t size, integer_type stat)
    {
      void *newmem;
    
      if (stat requested)
	stat = 0;

      newmem = malloc (MAX (size, 1));
      if (newmem == NULL)
      {
        if (stat)
          *stat = LIBERROR_ALLOCATION;
        else
	  runtime_error ("Allocation would exceed memory limit");
      }
      return newmem;
    }  */
void
gfc_allocate_using_malloc (stmtblock_t * block, tree pointer,
			   tree size, tree status)
{
  tree tmp, on_error, error_cond;
  tree status_type = status ? TREE_TYPE (status) : NULL_TREE;

  /* Evaluate size only once, and make sure it has the right type.  */
  size = gfc_evaluate_now (size, block);
  if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
    size = fold_convert (size_type_node, size);

  /* If successful and stat= is given, set status to 0.  */
  if (status != NULL_TREE)
      gfc_add_expr_to_block (block,
	     fold_build2_loc (input_location, MODIFY_EXPR, status_type,
			      status, build_int_cst (status_type, 0)));

  /* The allocation itself.  */
  gfc_add_modify (block, pointer,
	  fold_convert (TREE_TYPE (pointer),
		build_call_expr_loc (input_location,
			     builtin_decl_explicit (BUILT_IN_MALLOC), 1,
			     fold_build2_loc (input_location,
				      MAX_EXPR, size_type_node, size,
				      build_int_cst (size_type_node, 1)))));

  /* What to do in case of error.  */
  if (status != NULL_TREE)
    on_error = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
			status, build_int_cst (status_type, LIBERROR_ALLOCATION));
  else
    on_error = build_call_expr_loc (input_location, gfor_fndecl_os_error, 1,
		    gfc_build_addr_expr (pchar_type_node,
				 gfc_build_localized_cstring_const
				 ("Allocation would exceed memory limit")));

  error_cond = fold_build2_loc (input_location, EQ_EXPR,
				boolean_type_node, pointer,
				build_int_cst (prvoid_type_node, 0));
  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
			 gfc_unlikely (error_cond), on_error,
			 build_empty_stmt (input_location));

  gfc_add_expr_to_block (block, tmp);
}

static void
gimplify_switch_stmt (tree *stmt_p)
{
  tree stmt = *stmt_p;
  tree break_block, body;
  location_t stmt_locus = input_location;

  break_block = begin_bc_block (bc_break);

  body = SWITCH_STMT_BODY (stmt);
  if (!body)
    body = build_empty_stmt ();

  *stmt_p = build3 (SWITCH_EXPR, SWITCH_STMT_TYPE (stmt),
		    SWITCH_STMT_COND (stmt), body, NULL_TREE);
  SET_EXPR_LOCATION (*stmt_p, stmt_locus);
  gimplify_stmt (stmt_p);

  *stmt_p = finish_bc_block (bc_break, break_block, *stmt_p);
}

/* Free a given variable, if it's not NULL.  */
tree
gfc_call_free (tree var)
{
  stmtblock_t block;
  tree tmp, cond, call;

  if (TREE_TYPE (var) != TREE_TYPE (pvoid_type_node))
    var = fold_convert (pvoid_type_node, var);

  gfc_start_block (&block);
  var = gfc_evaluate_now (var, &block);
  cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, var,
			  build_int_cst (pvoid_type_node, 0));
  call = build_call_expr_loc (input_location,
			      built_in_decls[BUILT_IN_FREE], 1, var);
  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, call,
			 build_empty_stmt (input_location));
  gfc_add_expr_to_block (&block, tmp);

  return gfc_finish_block (&block);
}

static void
genericize_switch_stmt (tree *stmt_p, int *walk_subtrees, void *data)
{
  tree stmt = *stmt_p;
  tree break_block, body, cond, type;
  location_t stmt_locus = EXPR_LOCATION (stmt);

  break_block = begin_bc_block (bc_break, stmt_locus);

  body = SWITCH_STMT_BODY (stmt);
  if (!body)
    body = build_empty_stmt (stmt_locus);
  cond = SWITCH_STMT_COND (stmt);
  type = SWITCH_STMT_TYPE (stmt);

  cp_walk_tree (&body, cp_genericize_r, data, NULL);
  cp_walk_tree (&cond, cp_genericize_r, data, NULL);
  cp_walk_tree (&type, cp_genericize_r, data, NULL);
  *walk_subtrees = 0;

  *stmt_p = build3_loc (stmt_locus, SWITCH_EXPR, type, cond, body, NULL_TREE);
  finish_bc_block (stmt_p, bc_break, break_block);
}

static void
gimplify_switch_stmt (tree *stmt_p, gimple_seq *pre_p)
{
  tree stmt = *stmt_p;
  tree break_block, body, t;
  location_t stmt_locus = input_location;
  gimple_seq seq = NULL;

  break_block = begin_bc_block (bc_break);

  body = SWITCH_STMT_BODY (stmt);
  if (!body)
    body = build_empty_stmt ();

  t = build3 (SWITCH_EXPR, SWITCH_STMT_TYPE (stmt),
	      SWITCH_STMT_COND (stmt), body, NULL_TREE);
  SET_EXPR_LOCATION (t, stmt_locus);
  gimplify_and_add (t, &seq);

  seq = finish_bc_block (bc_break, break_block, seq);
  gimple_seq_add_seq (pre_p, seq);
  *stmt_p = NULL_TREE;
}

static tree
gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
{
  tree res, tmp, stmt;
  stmtblock_t block, *pblock = NULL;
  stmtblock_t singleblock;
  int saved_ompws_flags;
  bool singleblock_in_progress = false;
  /* True if previous gfc_code in workshare construct is not workshared.  */
  bool prev_singleunit;

  code = code->block->next;

  pushlevel (0);

  if (!code)
    return build_empty_stmt (input_location);

  gfc_start_block (&block);
  pblock = █

  ompws_flags = OMPWS_WORKSHARE_FLAG;
  prev_singleunit = false;

  /* Translate statements one by one to trees until we reach
     the end of the workshare construct.  Adjacent gfc_codes that
     are a single unit of work are clustered and encapsulated in a
     single OMP_SINGLE construct.  */
  for (; code; code = code->next)
    {
      if (code->here != 0)
	{
	  res = gfc_trans_label_here (code);
	  gfc_add_expr_to_block (pblock, res);
	}

      /* No dependence analysis, use for clauses with wait.
	 If this is the last gfc_code, use default omp_clauses.  */
      if (code->next == NULL && clauses->nowait)
	ompws_flags |= OMPWS_NOWAIT;

      /* By default, every gfc_code is a single unit of work.  */
      ompws_flags |= OMPWS_CURR_SINGLEUNIT;
      ompws_flags &= ~OMPWS_SCALARIZER_WS;

      switch (code->op)
	{
	case EXEC_NOP:
	  res = NULL_TREE;
	  break;

	case EXEC_ASSIGN:
	  res = gfc_trans_assign (code);
	  break;

	case EXEC_POINTER_ASSIGN:
	  res = gfc_trans_pointer_assign (code);
	  break;

	case EXEC_INIT_ASSIGN:
	  res = gfc_trans_init_assign (code);
	  break;

	case EXEC_FORALL:
	  res = gfc_trans_forall (code);
	  break;

	case EXEC_WHERE:
	  res = gfc_trans_where (code);
	  break;

	case EXEC_OMP_ATOMIC:
	  res = gfc_trans_omp_directive (code);
	  break;

	case EXEC_OMP_PARALLEL:
	case EXEC_OMP_PARALLEL_DO:
	case EXEC_OMP_PARALLEL_SECTIONS:
	case EXEC_OMP_PARALLEL_WORKSHARE:
	case EXEC_OMP_CRITICAL:
	  saved_ompws_flags = ompws_flags;
	  ompws_flags = 0;
	  res = gfc_trans_omp_directive (code);
	  ompws_flags = saved_ompws_flags;
	  break;
	
	default:
	  internal_error ("gfc_trans_omp_workshare(): Bad statement code");
	}

      gfc_set_backend_locus (&code->loc);

      if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
	{
	  if (prev_singleunit)
	    {
	      if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
		/* Add current gfc_code to single block.  */
		gfc_add_expr_to_block (&singleblock, res);
	      else
//.........这里部分代码省略.........

/* User-deallocate; we emit the code directly from the front-end, and the
   logic is the same as the previous library function:

    void
    deallocate (void *pointer, GFC_INTEGER_4 * stat)
    {
      if (!pointer)
	{
	  if (stat)
	    *stat = 1;
	  else
	    runtime_error ("Attempt to DEALLOCATE unallocated memory.");
	}
      else
	{
	  free (pointer);
	  if (stat)
	    *stat = 0;
	}
    }

   In this front-end version, status doesn't have to be GFC_INTEGER_4.
   Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
   even when no status variable is passed to us (this is used for
   unconditional deallocation generated by the front-end at end of
   each procedure).
   
   If a runtime-message is possible, `expr' must point to the original
   expression being deallocated for its locus and variable name.

   For coarrays, "pointer" must be the array descriptor and not its
   "data" component.  */
tree
gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
			    tree errlen, tree label_finish,
			    bool can_fail, gfc_expr* expr, bool coarray)
{
  stmtblock_t null, non_null;
  tree cond, tmp, error;
  tree status_type = NULL_TREE;
  tree caf_decl = NULL_TREE;

  if (coarray)
    {
      gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)));
      caf_decl = pointer;
      pointer = gfc_conv_descriptor_data_get (caf_decl);
      STRIP_NOPS (pointer);
    }

  cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
			  build_int_cst (TREE_TYPE (pointer), 0));

  /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
     we emit a runtime error.  */
  gfc_start_block (&null);
  if (!can_fail)
    {
      tree varname;

      gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);

      varname = gfc_build_cstring_const (expr->symtree->name);
      varname = gfc_build_addr_expr (pchar_type_node, varname);

      error = gfc_trans_runtime_error (true, &expr->where,
				       "Attempt to DEALLOCATE unallocated '%s'",
				       varname);
    }
  else
    error = build_empty_stmt (input_location);

  if (status != NULL_TREE && !integer_zerop (status))
    {
      tree cond2;

      status_type = TREE_TYPE (TREE_TYPE (status));
      cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
			       status, build_int_cst (TREE_TYPE (status), 0));
      tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
			     fold_build1_loc (input_location, INDIRECT_REF,
					      status_type, status),
			     build_int_cst (status_type, 1));
      error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
			       cond2, tmp, error);
    }

  gfc_add_expr_to_block (&null, error);

  /* When POINTER is not NULL, we free it.  */
  gfc_start_block (&non_null);
  if (!coarray || gfc_option.coarray != GFC_FCOARRAY_LIB)
    {
      tmp = build_call_expr_loc (input_location,
				 builtin_decl_explicit (BUILT_IN_FREE), 1,
				 fold_convert (pvoid_type_node, pointer));
      gfc_add_expr_to_block (&non_null, tmp);

      if (status != NULL_TREE && !integer_zerop (status))
	{
//.........这里部分代码省略.........

/* Generate code for an ALLOCATE statement when the argument is an
   allocatable variable.  If the variable is currently allocated, it is an
   error to allocate it again.
 
   This function follows the following pseudo-code:
  
    void *
    allocate_allocatable (void *mem, size_t size, integer_type stat)
    {
      if (mem == NULL)
	return allocate (size, stat);
      else
      {
	if (stat)
	  stat = LIBERROR_ALLOCATION;
	else
	  runtime_error ("Attempting to allocate already allocated variable");
      }
    }
    
    expr must be set to the original expression being allocated for its locus
    and variable name in case a runtime error has to be printed.  */
void
gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree token,
			  tree status, tree errmsg, tree errlen, tree label_finish,
			  gfc_expr* expr)
{
  stmtblock_t alloc_block;
  tree tmp, null_mem, alloc, error;
  tree type = TREE_TYPE (mem);

  if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
    size = fold_convert (size_type_node, size);

  null_mem = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
					    boolean_type_node, mem,
					    build_int_cst (type, 0)));

  /* If mem is NULL, we call gfc_allocate_using_malloc or
     gfc_allocate_using_lib.  */
  gfc_start_block (&alloc_block);

  if (gfc_option.coarray == GFC_FCOARRAY_LIB
      && gfc_expr_attr (expr).codimension)
    {
      tree cond;

      gfc_allocate_using_lib (&alloc_block, mem, size, token, status,
			      errmsg, errlen);
      if (status != NULL_TREE)
	{
	  TREE_USED (label_finish) = 1;
	  tmp = build1_v (GOTO_EXPR, label_finish);
	  cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
				  status, build_zero_cst (TREE_TYPE (status)));
	  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
				 gfc_unlikely (cond), tmp,
				 build_empty_stmt (input_location));
	  gfc_add_expr_to_block (&alloc_block, tmp);
	}
    }
  else
    gfc_allocate_using_malloc (&alloc_block, mem, size, status);

  alloc = gfc_finish_block (&alloc_block);

  /* If mem is not NULL, we issue a runtime error or set the
     status variable.  */
  if (expr)
    {
      tree varname;

      gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree);
      varname = gfc_build_cstring_const (expr->symtree->name);
      varname = gfc_build_addr_expr (pchar_type_node, varname);

      error = gfc_trans_runtime_error (true, &expr->where,
				       "Attempting to allocate already"
				       " allocated variable '%s'",
				       varname);
    }
  else
    error = gfc_trans_runtime_error (true, NULL,
				     "Attempting to allocate already allocated"
				     " variable");

  if (status != NULL_TREE)
    {
      tree status_type = TREE_TYPE (status);

      error = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
	      status, build_int_cst (status_type, LIBERROR_ALLOCATION));
    }

  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem,
			 error, alloc);
  gfc_add_expr_to_block (block, tmp);
}

static tree
trans_code (gfc_code * code, tree cond)
{
  stmtblock_t block;
  tree res;

  if (!code)
    return build_empty_stmt (input_location);

  gfc_start_block (&block);

  /* Translate statements one by one into GENERIC trees until we reach
     the end of this gfc_code branch.  */
  for (; code; code = code->next)
    {
      if (code->here != 0)
	{
	  res = gfc_trans_label_here (code);
	  gfc_add_expr_to_block (&block, res);
	}

      gfc_set_backend_locus (&code->loc);

      switch (code->op)
	{
	case EXEC_NOP:
	case EXEC_END_BLOCK:
	case EXEC_END_NESTED_BLOCK:
	case EXEC_END_PROCEDURE:
	  res = NULL_TREE;
	  break;

	case EXEC_ASSIGN:
	  if (code->expr1->ts.type == BT_CLASS)
	    res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
	  else
	    res = gfc_trans_assign (code);
	  break;

        case EXEC_LABEL_ASSIGN:
          res = gfc_trans_label_assign (code);
          break;

	case EXEC_POINTER_ASSIGN:
	  if (code->expr1->ts.type == BT_CLASS)
	    res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
	  else
	    res = gfc_trans_pointer_assign (code);
	  break;

	case EXEC_INIT_ASSIGN:
	  if (code->expr1->ts.type == BT_CLASS)
	    res = gfc_trans_class_init_assign (code);
	  else
	    res = gfc_trans_init_assign (code);
	  break;

	case EXEC_CONTINUE:
	  res = NULL_TREE;
	  break;

	case EXEC_CRITICAL:
	  res = gfc_trans_critical (code);
	  break;

	case EXEC_CYCLE:
	  res = gfc_trans_cycle (code);
	  break;

	case EXEC_EXIT:
	  res = gfc_trans_exit (code);
	  break;

	case EXEC_GOTO:
	  res = gfc_trans_goto (code);
	  break;

	case EXEC_ENTRY:
	  res = gfc_trans_entry (code);
	  break;

	case EXEC_PAUSE:
	  res = gfc_trans_pause (code);
	  break;

	case EXEC_STOP:
	case EXEC_ERROR_STOP:
	  res = gfc_trans_stop (code, code->op == EXEC_ERROR_STOP);
	  break;

	case EXEC_CALL:
	  /* For MVBITS we've got the special exception that we need a
	     dependency check, too.  */
	  {
	    bool is_mvbits = false;

	    if (code->resolved_isym)
	      {
		res = gfc_conv_intrinsic_subroutine (code);
		if (res != NULL_TREE)
//.........这里部分代码省略.........

tree
gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail,
				   gfc_expr* expr, gfc_typespec ts)
{
  stmtblock_t null, non_null;
  tree cond, tmp, error;

  cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
			  build_int_cst (TREE_TYPE (pointer), 0));

  /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
     we emit a runtime error.  */
  gfc_start_block (&null);
  if (!can_fail)
    {
      tree varname;

      gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);

      varname = gfc_build_cstring_const (expr->symtree->name);
      varname = gfc_build_addr_expr (pchar_type_node, varname);

      error = gfc_trans_runtime_error (true, &expr->where,
				       "Attempt to DEALLOCATE unallocated '%s'",
				       varname);
    }
  else
    error = build_empty_stmt (input_location);

  if (status != NULL_TREE && !integer_zerop (status))
    {
      tree status_type = TREE_TYPE (TREE_TYPE (status));
      tree cond2;

      cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
			       status, build_int_cst (TREE_TYPE (status), 0));
      tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
			     fold_build1_loc (input_location, INDIRECT_REF,
					      status_type, status),
			     build_int_cst (status_type, 1));
      error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
			       cond2, tmp, error);
    }

  gfc_add_expr_to_block (&null, error);

  /* When POINTER is not NULL, we free it.  */
  gfc_start_block (&non_null);
  
  /* Free allocatable components.  */
  if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
    {
      tmp = build_fold_indirect_ref_loc (input_location, pointer);
      tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
      gfc_add_expr_to_block (&non_null, tmp);
    }
  else if (ts.type == BT_CLASS
	   && ts.u.derived->components->ts.u.derived->attr.alloc_comp)
    {
      tmp = build_fold_indirect_ref_loc (input_location, pointer);
      tmp = gfc_deallocate_alloc_comp (ts.u.derived->components->ts.u.derived,
				       tmp, 0);
      gfc_add_expr_to_block (&non_null, tmp);
    }
  
  tmp = build_call_expr_loc (input_location,
			     builtin_decl_explicit (BUILT_IN_FREE), 1,
			     fold_convert (pvoid_type_node, pointer));
  gfc_add_expr_to_block (&non_null, tmp);

  if (status != NULL_TREE && !integer_zerop (status))
    {
      /* We set STATUS to zero if it is present.  */
      tree status_type = TREE_TYPE (TREE_TYPE (status));
      tree cond2;

      cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
			       status, build_int_cst (TREE_TYPE (status), 0));
      tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
			     fold_build1_loc (input_location, INDIRECT_REF,
					      status_type, status),
			     build_int_cst (status_type, 0));
      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
			     tmp, build_empty_stmt (input_location));
      gfc_add_expr_to_block (&non_null, tmp);
    }

  return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
			  gfc_finish_block (&null),
			  gfc_finish_block (&non_null));
}

/* User-deallocate; we emit the code directly from the front-end, and the
   logic is the same as the previous library function:

    void
    deallocate (void *pointer, GFC_INTEGER_4 * stat)
    {
      if (!pointer)
	{
	  if (stat)
	    *stat = 1;
	  else
	    runtime_error ("Attempt to DEALLOCATE unallocated memory.");
	}
      else
	{
	  free (pointer);
	  if (stat)
	    *stat = 0;
	}
    }

   In this front-end version, status doesn't have to be GFC_INTEGER_4.
   Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
   even when no status variable is passed to us (this is used for
   unconditional deallocation generated by the front-end at end of
   each procedure).
   
   If a runtime-message is possible, `expr' must point to the original
   expression being deallocated for its locus and variable name.  */
tree
gfc_deallocate_with_status (tree pointer, tree status, bool can_fail,
			    gfc_expr* expr)
{
  stmtblock_t null, non_null;
  tree cond, tmp, error;

  cond = fold_build2 (EQ_EXPR, boolean_type_node, pointer,
		      build_int_cst (TREE_TYPE (pointer), 0));

  /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
     we emit a runtime error.  */
  gfc_start_block (&null);
  if (!can_fail)
    {
      tree varname;

      gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);

      varname = gfc_build_cstring_const (expr->symtree->name);
      varname = gfc_build_addr_expr (pchar_type_node, varname);

      error = gfc_trans_runtime_error (true, &expr->where,
				       "Attempt to DEALLOCATE unallocated '%s'",
				       varname);
    }
  else
    error = build_empty_stmt (input_location);

  if (status != NULL_TREE && !integer_zerop (status))
    {
      tree status_type = TREE_TYPE (TREE_TYPE (status));
      tree cond2;

      cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
			   build_int_cst (TREE_TYPE (status), 0));
      tmp = fold_build2 (MODIFY_EXPR, status_type,
			 fold_build1 (INDIRECT_REF, status_type, status),
			 build_int_cst (status_type, 1));
      error = fold_build3 (COND_EXPR, void_type_node, cond2, tmp, error);
    }

  gfc_add_expr_to_block (&null, error);

  /* When POINTER is not NULL, we free it.  */
  gfc_start_block (&non_null);
  tmp = build_call_expr_loc (input_location,
			 built_in_decls[BUILT_IN_FREE], 1,
			 fold_convert (pvoid_type_node, pointer));
  gfc_add_expr_to_block (&non_null, tmp);

  if (status != NULL_TREE && !integer_zerop (status))
    {
      /* We set STATUS to zero if it is present.  */
      tree status_type = TREE_TYPE (TREE_TYPE (status));
      tree cond2;

      cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
			   build_int_cst (TREE_TYPE (status), 0));
      tmp = fold_build2 (MODIFY_EXPR, status_type,
			 fold_build1 (INDIRECT_REF, status_type, status),
			 build_int_cst (status_type, 0));
      tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp,
			 build_empty_stmt (input_location));
      gfc_add_expr_to_block (&non_null, tmp);
    }

  return fold_build3 (COND_EXPR, void_type_node, cond,
		      gfc_finish_block (&null), gfc_finish_block (&non_null));
}

/* Allocate memory, using an optional status argument.
 
   This function follows the following pseudo-code:

    void *
    allocate (size_t size, integer_type* stat)
    {
      void *newmem;
    
      if (stat)
	*stat = 0;

      newmem = malloc (MAX (size, 1));
      if (newmem == NULL)
      {
        if (stat)
          *stat = LIBERROR_ALLOCATION;
        else
	  runtime_error ("Allocation would exceed memory limit");
      }
      return newmem;
    }  */
tree
gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
{
  stmtblock_t alloc_block;
  tree res, tmp, msg, cond;
  tree status_type = status ? TREE_TYPE (TREE_TYPE (status)) : NULL_TREE;

  /* Evaluate size only once, and make sure it has the right type.  */
  size = gfc_evaluate_now (size, block);
  if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
    size = fold_convert (size_type_node, size);

  /* Create a variable to hold the result.  */
  res = gfc_create_var (prvoid_type_node, NULL);

  /* Set the optional status variable to zero.  */
  if (status != NULL_TREE && !integer_zerop (status))
    {
      tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
			     fold_build1_loc (input_location, INDIRECT_REF,
					      status_type, status),
			     build_int_cst (status_type, 0));
      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
			     fold_build2_loc (input_location, NE_EXPR,
					boolean_type_node, status,
					build_int_cst (TREE_TYPE (status), 0)),
			     tmp, build_empty_stmt (input_location));
      gfc_add_expr_to_block (block, tmp);
    }

  /* The allocation itself.  */
  gfc_start_block (&alloc_block);
  gfc_add_modify (&alloc_block, res,
		  fold_convert (prvoid_type_node,
				build_call_expr_loc (input_location,
				   built_in_decls[BUILT_IN_MALLOC], 1,
					fold_build2_loc (input_location,
					    MAX_EXPR, size_type_node, size,
					    build_int_cst (size_type_node,
							   1)))));

  msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
			     ("Allocation would exceed memory limit"));
  tmp = build_call_expr_loc (input_location,
			 gfor_fndecl_os_error, 1, msg);

  if (status != NULL_TREE && !integer_zerop (status))
    {
      /* Set the status variable if it's present.  */
      tree tmp2;

      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
			      status, build_int_cst (TREE_TYPE (status), 0));
      tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
			      fold_build1_loc (input_location, INDIRECT_REF,
					       status_type, status),
			      build_int_cst (status_type, LIBERROR_ALLOCATION));
      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
			     tmp, tmp2);
    }

  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
			 fold_build2_loc (input_location, EQ_EXPR,
					  boolean_type_node, res,
					  build_int_cst (prvoid_type_node, 0)),
			 tmp, build_empty_stmt (input_location));