/* Statement translation -- generate GCC trees from gfc_code.
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
#include "system.h"
#include "coretypes.h"
#include "tree.h"
-#include "gimple.h"
-#include "ggc.h"
-#include "toplev.h"
-#include "real.h"
#include "gfortran.h"
#include "flags.h"
#include "trans.h"
assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr);
- code = code->block;
- if (code == NULL)
- {
- target = fold_build1 (GOTO_EXPR, void_type_node, assigned_goto);
- gfc_add_expr_to_block (&se.pre, target);
- return gfc_finish_block (&se.pre);
- }
+ /* 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. */
- /* Check the label list. */
- do
- {
- target = gfc_get_label_decl (code->label1);
- tmp = gfc_build_addr_expr (pvoid_type_node, target);
- tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, assigned_goto);
- tmp = build3_v (COND_EXPR, tmp,
- fold_build1 (GOTO_EXPR, void_type_node, target),
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&se.pre, tmp);
- code = code->block;
- }
- while (code != NULL);
- gfc_trans_runtime_check (true, false, boolean_true_node, &se.pre, &loc,
- "Assigned label is not in the list");
-
- return gfc_finish_block (&se.pre);
+ target = fold_build1 (GOTO_EXPR, void_type_node, assigned_goto);
+ gfc_add_expr_to_block (&se.pre, target);
+ return gfc_finish_block (&se.pre);
}
gfc_ss *ss;
gfc_ss_info *info;
gfc_symbol *fsym;
+ gfc_ref *ref;
int n;
tree data;
tree offset;
/* Obtain the argument descriptor for unpacking. */
gfc_init_se (&parmse, NULL);
parmse.want_pointer = 1;
+
+ /* The scalarizer introduces some specific peculiarities when
+ handling elemental subroutines; the stride can be needed up to
+ the dim_array - 1, rather than dim_loop - 1 to calculate
+ offsets outside the loop. For this reason, we make sure that
+ the descriptor has the dimensionality of the array by converting
+ trailing elements into ranges with end = start. */
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
+ break;
+
+ if (ref)
+ {
+ bool seen_range = false;
+ for (n = 0; n < ref->u.ar.dimen; n++)
+ {
+ if (ref->u.ar.dimen_type[n] == DIMEN_RANGE)
+ seen_range = true;
+
+ if (!seen_range
+ || ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
+ continue;
+
+ ref->u.ar.end[n] = gfc_copy_expr (ref->u.ar.start[n]);
+ ref->u.ar.dimen_type[n] = DIMEN_RANGE;
+ }
+ }
+
gfc_conv_expr_descriptor (&parmse, e, gfc_walk_expr (e));
gfc_add_block_to_block (&se->pre, &parmse.pre);
if (code->expr1 == NULL)
{
- tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code);
+ 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, tmp);
+ gfor_fndecl_pause_numeric, 1,
+ fold_convert (gfc_int4_type_node, se.expr));
}
else
{
to a runtime library call. */
tree
-gfc_trans_stop (gfc_code * code)
+gfc_trans_stop (gfc_code *code, bool error_stop)
{
tree gfc_int4_type_node = gfc_get_int_type (4);
gfc_se se;
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
-
if (code->expr1 == NULL)
{
- tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code);
+ tmp = build_int_cst (gfc_int4_type_node, 0);
tmp = build_call_expr_loc (input_location,
- gfor_fndecl_stop_numeric, 1, tmp);
+ error_stop ? 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 ? gfor_fndecl_error_stop_numeric
+ : gfor_fndecl_stop_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_stop_string, 2,
- se.expr, se.string_length);
+ error_stop ? gfor_fndecl_error_stop_string
+ : gfor_fndecl_stop_string,
+ 2, se.expr, se.string_length);
}
gfc_add_expr_to_block (&se.pre, tmp);
}
+tree
+gfc_trans_sync (gfc_code *code, gfc_exec_op type __attribute__ ((unused)))
+{
+ gfc_se se;
+
+ if ((code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) || code->expr2)
+ {
+ gfc_init_se (&se, NULL);
+ gfc_start_block (&se.pre);
+ }
+
+ /* 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;
+ gfc_conv_expr (&se, code->expr1);
+ cond = fold_build2 (NE_EXPR, boolean_type_node, se.expr,
+ build_int_cst (TREE_TYPE (se.expr), 1));
+ 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));
+ }
+
+ /* If STAT is present, set it to zero. */
+ if (code->expr2)
+ {
+ gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
+ gfc_conv_expr (&se, code->expr2);
+ gfc_add_modify (&se.pre, se.expr, build_int_cst (TREE_TYPE (se.expr), 0));
+ }
+
+ if ((code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) || code->expr2)
+ return gfc_finish_block (&se.pre);
+
+ return NULL_TREE;
+}
+
+
/* 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.
}
+/* Translate a CRITICAL block. */
+tree
+gfc_trans_critical (gfc_code *code)
+{
+ stmtblock_t block;
+ tree tmp;
+
+ gfc_start_block (&block);
+ tmp = gfc_trans_code (code->block->next);
+ gfc_add_expr_to_block (&block, tmp);
+
+ return gfc_finish_block (&block);
+}
+
+
+/* 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;
+ stmtblock_t body;
+ tree tmp;
+
+ ns = code->ext.block.ns;
+ gcc_assert (ns);
+ sym = ns->proc_name;
+ gcc_assert (sym);
+
+ gcc_assert (!sym->tlink);
+ sym->tlink = sym;
+
+ gfc_start_block (&body);
+ gfc_process_block_locals (ns);
+
+ tmp = gfc_trans_code (ns->code);
+ tmp = gfc_trans_deferred_vars (sym, tmp);
+
+ gfc_add_expr_to_block (&body, tmp);
+ return gfc_finish_block (&body);
+}
+
+
/* 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
static tree
gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
- tree from, tree to, tree step)
+ tree from, tree to, tree step, tree exit_cond)
{
stmtblock_t body;
tree type;
gfc_start_block (&body);
/* Main loop body. */
- tmp = gfc_trans_code (code->block->next);
+ tmp = gfc_trans_code_cond (code->block->next, exit_cond);
gfc_add_expr_to_block (&body, tmp);
/* Label for cycle statements (if needed). */
"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 (COND_EXPR, void_type_node, exit_cond, tmp,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&body, tmp);
+ }
+
/* Evaluate the loop condition. */
cond = fold_build2 (EQ_EXPR, boolean_type_node, dovar, to);
cond = gfc_evaluate_now (cond, &body);
because the loop count itself can overflow. */
tree
-gfc_trans_do (gfc_code * code)
+gfc_trans_do (gfc_code * code, tree exit_cond)
{
gfc_se se;
tree dovar;
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);
+ return gfc_trans_simple_do (code, &block, dovar, from, to, step, exit_cond);
pos_step = fold_build2 (GT_EXPR, boolean_type_node, step,
fold_convert (type, integer_zero_node));
/* 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;
- countm1 = (to - from) / step;
+ if (to < from)
+ goto exit_label;
}
else
{
- if (to > from) goto exit_label;
- countm1 = (from - to) / -step;
- } */
+ 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;
+ tree pos, neg, step_sign, to2, from2, step2;
+
+ /* Calculate SIGN (1,step), as (step < 0 ? -1 : 1) */
+
+ tmp = fold_build2 (LT_EXPR, boolean_type_node, step,
+ build_int_cst (TREE_TYPE (step), 0));
+ step_sign = fold_build3 (COND_EXPR, type, tmp,
+ build_int_cst (type, -1),
+ build_int_cst (type, 1));
tmp = fold_build2 (LT_EXPR, boolean_type_node, to, from);
pos = fold_build3 (COND_EXPR, void_type_node, tmp,
build1_v (GOTO_EXPR, exit_label),
build_empty_stmt (input_location));
- tmp = fold_build2 (MINUS_EXPR, type, to, from);
- tmp = fold_convert (utype, tmp);
- tmp = fold_build2 (TRUNC_DIV_EXPR, utype, tmp,
- fold_convert (utype, step));
- tmp = build2 (MODIFY_EXPR, void_type_node, countm1, tmp);
- pos = build2 (COMPOUND_EXPR, void_type_node, pos, tmp);
tmp = fold_build2 (GT_EXPR, boolean_type_node, to, from);
neg = fold_build3 (COND_EXPR, void_type_node, tmp,
build1_v (GOTO_EXPR, exit_label),
build_empty_stmt (input_location));
- tmp = fold_build2 (MINUS_EXPR, type, from, to);
- tmp = fold_convert (utype, tmp);
- tmp = fold_build2 (TRUNC_DIV_EXPR, utype, tmp,
- fold_convert (utype, fold_build1 (NEGATE_EXPR,
- type, step)));
- tmp = build2 (MODIFY_EXPR, void_type_node, countm1, tmp);
- neg = build2 (COMPOUND_EXPR, void_type_node, neg, tmp);
-
tmp = fold_build3 (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 (MULT_EXPR, type, step_sign, to);
+ from2 = fold_build2 (MULT_EXPR, type, step_sign, from);
+ step2 = fold_build2 (MULT_EXPR, type, step_sign, step);
+ step2 = fold_convert (utype, step2);
+ tmp = fold_build2 (MINUS_EXPR, type, to2, from2);
+ tmp = fold_convert (utype, tmp);
+ tmp = fold_build2 (TRUNC_DIV_EXPR, utype, tmp, step2);
+ tmp = fold_build2 (MODIFY_EXPR, void_type_node, countm1, tmp);
gfc_add_expr_to_block (&block, tmp);
}
else
code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
/* Main loop body. */
- tmp = gfc_trans_code (code->block->next);
+ tmp = gfc_trans_code_cond (code->block->next, exit_cond);
gfc_add_expr_to_block (&body, tmp);
/* Label for cycle statements (if needed). */
"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 (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 (PLUS_EXPR, type, dovar, step);
gfc_add_modify (&body, dovar, tmp);
static tree
gfc_trans_character_select (gfc_code *code)
{
- tree init, node, end_label, tmp, type, case_num, label, fndecl;
+ tree init, end_label, tmp, type, case_num, label, fndecl;
stmtblock_t block, body;
gfc_case *cp, *d;
gfc_code *c;
gfc_se se;
int n, k;
+ VEC(constructor_elt,gc) *inits = NULL;
/* The jump table types are stored in static variables to avoid
constructing them from scratch every single time. */
}
/* Generate the structure describing the branches */
- init = NULL_TREE;
-
for(d = cp; d; d = d->right)
{
- node = NULL_TREE;
+ VEC(constructor_elt,gc) *node = NULL;
gfc_init_se (&se, NULL);
if (d->low == NULL)
{
- node = tree_cons (ss_string1[k], null_pointer_node, node);
- node = tree_cons (ss_string1_len[k], integer_zero_node, node);
+ 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);
- node = tree_cons (ss_string1[k], se.expr, node);
- node = tree_cons (ss_string1_len[k], se.string_length, node);
+ CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], se.expr);
+ CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], se.string_length);
}
if (d->high == NULL)
{
- node = tree_cons (ss_string2[k], null_pointer_node, node);
- node = tree_cons (ss_string2_len[k], integer_zero_node, node);
+ 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);
- node = tree_cons (ss_string2[k], se.expr, node);
- node = tree_cons (ss_string2_len[k], se.string_length, node);
+ CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], se.expr);
+ CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], se.string_length);
}
- node = tree_cons (ss_target[k], build_int_cst (integer_type_node, d->n),
- node);
+ CONSTRUCTOR_APPEND_ELT (node, ss_target[k],
+ build_int_cst (integer_type_node, d->n));
- tmp = build_constructor_from_list (select_struct[k], nreverse (node));
- init = tree_cons (NULL_TREE, tmp, init);
+ tmp = build_constructor (select_struct[k], node);
+ CONSTRUCTOR_APPEND_ELT (inits, NULL_TREE, tmp);
}
type = build_array_type (select_struct[k],
build_index_type (build_int_cst (NULL_TREE, n-1)));
- init = build_constructor_from_list (type, nreverse(init));
+ init = build_constructor (type, inits);
TREE_CONSTANT (init) = 1;
TREE_STATIC (init) = 1;
/* Create a static variable to hold the jump table. */
if (old_sym->attr.dimension)
{
gfc_init_se (&tse, NULL);
- gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN);
+ 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);
}
tmp = gfc_trans_scalar_assign (&tse, &rse, e->ts, true,
- e->expr_type == EXPR_VARIABLE);
+ e->expr_type == EXPR_VARIABLE, true);
gfc_add_expr_to_block (pre, tmp);
}
gfc_free_expr (e);
pointer components. We therefore leave these to their
own devices. */
if (lsym->ts.type == BT_DERIVED
- && lsym->ts.derived->attr.pointer_comp)
+ && lsym->ts.u.derived->attr.pointer_comp)
return need_temp;
new_symtree = NULL;
/* Use the scalar assignment. */
rse.string_length = lse.string_length;
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true, true);
/* Form the mask expression according to the mask tree list. */
if (wheremask)
/* 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);
+ expr2->expr_type == EXPR_VARIABLE, true);
/* Form the mask expression according to the mask tree list. */
if (wheremask)
&lss, &rss);
/* The type of LHS. Used in function allocate_temp_for_forall_nest */
- if (expr1->ts.type == BT_CHARACTER && expr1->ts.cl->length)
+ if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->length)
{
- if (!expr1->ts.cl->backend_decl)
+ if (!expr1->ts.u.cl->backend_decl)
{
gfc_se tse;
gfc_init_se (&tse, NULL);
- gfc_conv_expr (&tse, expr1->ts.cl->length);
- expr1->ts.cl->backend_decl = tse.expr;
+ 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.cl->backend_decl);
+ expr1->ts.u.cl->backend_decl);
}
else
type = gfc_typenode_for_spec (&expr1->ts);
/* Make a new descriptor. */
parmtype = gfc_get_element_type (TREE_TYPE (desc));
- parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
+ parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
loop.from, loop.to, 1,
- GFC_ARRAY_UNKNOWN);
+ GFC_ARRAY_UNKNOWN, true);
/* Allocate temporary for nested forall construct. */
tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,
else
{
/* Use the normal assignment copying routines. */
- assign = gfc_trans_assignment (c->expr1, c->expr2, false);
+ assign = gfc_trans_assignment (c->expr1, c->expr2, false, true);
/* Generate body and loops. */
tmp = gfc_trans_nested_forall_loop (nested_forall_info,
/* Use the scalar assignment as is. */
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
- loop.temp_ss != NULL, false);
+ loop.temp_ss != NULL, false, true);
tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt (input_location));
maskexpr);
/* Use the scalar assignment as is. */
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false);
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false,
+ true);
tmp = build3_v (COND_EXPR, maskexpr, tmp,
build_empty_stmt (input_location));
gfc_add_expr_to_block (&body, tmp);
gfc_conv_expr (&edse, edst);
}
- tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false);
- estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, false, false)
+ tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false, true);
+ estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, false,
+ false, true)
: build_empty_stmt (input_location);
tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
gfc_add_expr_to_block (&body, tmp);
tree stat;
tree pstat;
tree error_label;
+ tree memsz;
stmtblock_t block;
- if (!code->ext.alloc_list)
+ if (!code->ext.alloc.list)
return NULL_TREE;
- pstat = stat = error_label = tmp = NULL_TREE;
+ pstat = stat = error_label = tmp = memsz = NULL_TREE;
gfc_start_block (&block);
TREE_USED (error_label) = 1;
}
- for (al = code->ext.alloc_list; al != NULL; al = al->next)
+ for (al = code->ext.alloc.list; al != NULL; al = al->next)
{
- expr = al->expr;
+ expr = gfc_copy_expr (al->expr);
+
+ if (expr->ts.type == BT_CLASS)
+ gfc_add_component_ref (expr, "$data");
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
if (!gfc_array_allocate (&se, expr, pstat))
{
/* A scalar or derived type. */
- tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
- if (expr->ts.type == BT_CHARACTER && tmp == NULL_TREE)
- tmp = se.string_length;
+ /* Determine allocate size. */
+ if (al->expr->ts.type == BT_CLASS && code->expr3)
+ {
+ if (code->expr3->ts.type == BT_CLASS)
+ {
+ gfc_expr *sz;
+ gfc_se se_sz;
+ sz = gfc_copy_expr (code->expr3);
+ gfc_add_component_ref (sz, "$vptr");
+ gfc_add_component_ref (sz, "$size");
+ gfc_init_se (&se_sz, NULL);
+ gfc_conv_expr (&se_sz, sz);
+ gfc_free_expr (sz);
+ memsz = se_sz.expr;
+ }
+ else
+ memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts));
+ }
+ else if (code->ext.alloc.ts.type != BT_UNKNOWN)
+ memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
+ else
+ memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
+
+ if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE)
+ memsz = se.string_length;
+
+ /* Allocate - for non-pointers with re-alloc checking. */
+ {
+ gfc_ref *ref;
+ bool allocatable;
+
+ ref = expr->ref;
+
+ /* Find the last reference in the chain. */
+ while (ref && ref->next != NULL)
+ {
+ gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
+ ref = ref->next;
+ }
+
+ if (!ref)
+ allocatable = expr->symtree->n.sym->attr.allocatable;
+ else
+ allocatable = ref->u.c.component->attr.allocatable;
+
+ if (allocatable)
+ tmp = gfc_allocate_array_with_status (&se.pre, se.expr, memsz,
+ pstat, expr);
+ else
+ tmp = gfc_allocate_with_status (&se.pre, memsz, pstat);
+ }
- tmp = gfc_allocate_with_status (&se.pre, tmp, pstat);
tmp = fold_build2 (MODIFY_EXPR, void_type_node, se.expr,
fold_convert (TREE_TYPE (se.expr), tmp));
gfc_add_expr_to_block (&se.pre, tmp);
gfc_add_expr_to_block (&se.pre, tmp);
}
- if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp)
+ if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
{
tmp = build_fold_indirect_ref_loc (input_location, se.expr);
- tmp = gfc_nullify_alloc_comp (expr->ts.derived, tmp, 0);
+ tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0);
gfc_add_expr_to_block (&se.pre, tmp);
}
tmp = gfc_finish_block (&se.pre);
gfc_add_expr_to_block (&block, tmp);
+
+ /* Initialization via SOURCE block. */
+ if (code->expr3 && !code->expr3->mold)
+ {
+ gfc_expr *rhs = gfc_copy_expr (code->expr3);
+ if (al->expr->ts.type == BT_CLASS)
+ {
+ gfc_se dst,src;
+ if (rhs->ts.type == BT_CLASS)
+ gfc_add_component_ref (rhs, "$data");
+ gfc_init_se (&dst, NULL);
+ gfc_init_se (&src, NULL);
+ gfc_conv_expr (&dst, expr);
+ gfc_conv_expr (&src, rhs);
+ gfc_add_block_to_block (&block, &src.pre);
+ tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz);
+ }
+ else
+ tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
+ rhs, false, false);
+ gfc_free_expr (rhs);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+
+ /* Allocation of CLASS entities. */
+ gfc_free_expr (expr);
+ expr = al->expr;
+ if (expr->ts.type == BT_CLASS)
+ {
+ gfc_expr *lhs,*rhs;
+ gfc_se lse;
+
+ /* Initialize VPTR for CLASS objects. */
+ lhs = gfc_expr_to_initialize (expr);
+ gfc_add_component_ref (lhs, "$vptr");
+ rhs = NULL;
+ if (code->expr3 && code->expr3->ts.type == BT_CLASS)
+ {
+ /* Polymorphic SOURCE: VPTR must be determined at run time. */
+ rhs = gfc_copy_expr (code->expr3);
+ gfc_add_component_ref (rhs, "$vptr");
+ tmp = gfc_trans_pointer_assignment (lhs, rhs);
+ gfc_add_expr_to_block (&block, tmp);
+ gfc_free_expr (rhs);
+ }
+ else
+ {
+ /* VPTR is fixed at compile time. */
+ gfc_symbol *vtab;
+ gfc_typespec *ts;
+ if (code->expr3)
+ ts = &code->expr3->ts;
+ else if (expr->ts.type == BT_DERIVED)
+ ts = &expr->ts;
+ else if (code->ext.alloc.ts.type == BT_DERIVED)
+ ts = &code->ext.alloc.ts;
+ else if (expr->ts.type == BT_CLASS)
+ ts = &CLASS_DATA (expr)->ts;
+ else
+ ts = &expr->ts;
+
+ if (ts->type == BT_DERIVED)
+ {
+ vtab = gfc_find_derived_vtab (ts->u.derived, true);
+ gcc_assert (vtab);
+ gfc_trans_assign_vtab_procs (&block, ts->u.derived, vtab);
+ gfc_init_se (&lse, NULL);
+ lse.want_pointer = 1;
+ gfc_conv_expr (&lse, lhs);
+ tmp = gfc_build_addr_expr (NULL_TREE,
+ gfc_get_symbol_decl (vtab));
+ gfc_add_modify (&block, lse.expr,
+ fold_convert (TREE_TYPE (lse.expr), tmp));
+ }
+ }
+ }
+
}
/* STAT block. */
gfc_add_modify (&block, astat, build_int_cst (TREE_TYPE (astat), 0));
}
- for (al = code->ext.alloc_list; al != NULL; al = al->next)
+ for (al = code->ext.alloc.list; al != NULL; al = al->next)
{
expr = al->expr;
gcc_assert (expr->expr_type == EXPR_VARIABLE);
se.descriptor_only = 1;
gfc_conv_expr (&se, expr);
- if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp)
+ if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
{
gfc_ref *ref;
gfc_ref *last = NULL;
if (!(last && last->u.c.component->attr.pointer)
&& !(!last && expr->symtree->n.sym->attr.pointer))
{
- tmp = gfc_deallocate_alloc_comp (expr->ts.derived, se.expr,
+ tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se.expr,
expr->rank);
gfc_add_expr_to_block (&se.pre, tmp);
}
OSDN Git Service
