/* Statement translation -- generate GCC trees from gfc_code.
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
- 2011
+ 2011, 2012
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
gfc_expr *format = code->label1->format;
label_len = format->value.character.length;
- len_tree = build_int_cst (NULL_TREE, label_len);
+ 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);
}
+/* 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
gfc_actual_arglist *arg0;
gfc_expr *e;
gfc_formal_arglist *formal;
- gfc_loopinfo tmp_loop;
gfc_se parmse;
gfc_ss *ss;
- gfc_ss_info *info;
gfc_symbol *fsym;
- gfc_ref *ref;
- int n;
tree data;
- tree offset;
tree size;
tree tmp;
continue;
/* Obtain the info structure for the current argument. */
- info = NULL;
for (ss = loopse->ss; ss && ss != gfc_ss_terminator; ss = ss->next)
- {
- if (ss->expr != e)
- continue;
- info = &ss->data.info;
+ if (ss->info->expr == e)
break;
- }
/* If there is a dependency, create a temporary and use it
instead of the variable. */
{
tree initial, temptype;
stmtblock_t temp_post;
+ gfc_ss *tmp_ss;
- /* Make a local loopinfo for the temporary creation, so that
- none of the other ss->info's have to be renormalized. */
- gfc_init_loopinfo (&tmp_loop);
- tmp_loop.dimen = info->dimen;
- for (n = 0; n < info->dimen; n++)
- {
- tmp_loop.to[n] = loopse->loop->to[n];
- tmp_loop.from[n] = loopse->loop->from[n];
- tmp_loop.order[n] = loopse->loop->order[n];
- }
+ 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;
-
- /* 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);
|| (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;
- /* 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);
+ 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
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_loop, info, temptype,
- initial,
- false, true, false,
- &arg->expr->where);
+ 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, info->data);
+ tmp = fold_convert (pvoid_type_node, tmp_ss->info->data.array.data);
gfc_add_modify (&se->pre, data, tmp);
- /* Calculate the offset for the temporary. */
- offset = gfc_index_zero_node;
- for (n = 0; n < info->dimen; n++)
+ /* 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
{
- tmp = gfc_conv_descriptor_stride_get (info->descriptor,
- gfc_rank_cst[n]);
- tmp = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type,
- loopse->loop->from[n], tmp);
- offset = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, offset, tmp);
+ /* ... 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);
}
- info->offset = gfc_create_var (gfc_array_index_type, NULL);
- gfc_add_modify (&se->pre, info->offset, offset);
-
- /* Copy the result back using unpack. */
- tmp = build_call_expr_loc (input_location,
- gfor_fndecl_in_unpack, 2, parmse.expr, data);
gfc_add_expr_to_block (&se->post, tmp);
/* parmse.pre is already added above. */
}
+/* 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
ss = gfc_ss_terminator;
if (code->resolved_sym->attr.elemental)
- ss = gfc_walk_elemental_function_args (ss, code->ext.actual, GFC_SS_REFERENCE);
+ 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)
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 ? gfor_fndecl_error_stop_string
+ 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);
}
{
gfc_conv_expr (&se, code->expr1);
tmp = build_call_expr_loc (input_location,
- error_stop ? gfor_fndecl_error_stop_numeric
+ 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));
}
{
gfc_conv_expr_reference (&se, code->expr1);
tmp = build_call_expr_loc (input_location,
- error_stop ? gfor_fndecl_error_stop_string
+ 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);
}
tree
-gfc_trans_sync (gfc_code *code, gfc_exec_op type __attribute__ ((unused)))
+gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op type ATTRIBUTE_UNUSED)
{
- gfc_se se;
+ 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->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) || code->expr2)
+ if (code->expr2)
{
- gfc_init_se (&se, NULL);
- gfc_start_block (&se.pre);
+ 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.
&& code->expr1->rank == 0)
{
tree cond;
- gfc_conv_expr (&se, code->expr1);
- cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
- se.expr, build_int_cst (TREE_TYPE (se.expr), 1));
+ 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));
}
- /* If STAT is present, set it to zero. */
- if (code->expr2)
+ /* 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)
{
- 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));
+ /* 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 ((code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) || code->expr2)
- return gfc_finish_block (&se.pre);
-
- return NULL_TREE;
+ 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);
}
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);
}
{
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
+ if (sym->attr.dimension && !class_target
&& (sym->as->type == AS_DEFERRED || sym->assoc->variable))
{
gfc_se se;
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))
{
loc = code->ext.iterator->start->where.lb->location;
/* Initialize the DO variable: dovar = from. */
- gfc_add_modify_loc (loc, pblock, 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)
/* Add this case label.
Add parameter 'label', make it match GCC backend. */
- tmp = fold_build3_loc (input_location, CASE_LABEL_EXPR,
- void_type_node, low, high, label);
+ tmp = build_case_label (low, high, label);
gfc_add_expr_to_block (&body, tmp);
}
/* Add this case label.
Add parameter 'label', make it match GCC backend. */
- tmp = fold_build3_loc (input_location, CASE_LABEL_EXPR,
- void_type_node, low, high, label);
+ tmp = build_case_label (low, high, label);
gfc_add_expr_to_block (&body, tmp);
}
for (d = c->ext.block.case_list; d; d = d->next)
{
label = gfc_build_label_decl (NULL_TREE);
- tmp = fold_build3_loc (input_location, CASE_LABEL_EXPR,
- void_type_node,
- (d->low == NULL && d->high == NULL)
- ? NULL : build_int_cst (NULL_TREE, d->n),
- NULL, label);
+ 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);
}
}
type = build_array_type (select_struct[k],
- build_index_type (build_int_cst (NULL_TREE, n-1)));
+ build_index_type (size_int (n-1)));
init = build_constructor (type, inits);
TREE_CONSTANT (init) = 1;
gcc_unreachable ();
tmp = build_call_expr_loc (input_location,
- fndecl, 4, init, build_int_cst (NULL_TREE, n),
+ 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);
{
forall_restore_symtree (c->expr1);
forall_restore_symtree (c->expr2);
- gfc_free (new_symtree->n.sym);
- gfc_free (new_symtree);
+ free (new_symtree->n.sym);
+ free (new_symtree);
}
/* 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_ss ();
- (*rss)->next = gfc_ss_terminator;
- (*rss)->type = GFC_SS_SCALAR;
- (*rss)->expr = expr2;
- }
+ /* 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);
gfc_ss *lss, *rss;
gfc_se lse;
gfc_se rse;
- gfc_ss_info *info;
+ gfc_array_info *info;
gfc_loopinfo loop;
tree desc;
tree parm;
count = gfc_create_var (gfc_array_index_type, "count");
gfc_add_modify (block, count, gfc_index_zero_node);
- inner_size = integer_one_node;
+ inner_size = gfc_index_one_node;
lss = gfc_walk_expr (expr1);
rss = gfc_walk_expr (expr2);
if (lss == gfc_ss_terminator)
gfc_conv_loop_setup (&loop, &expr2->where);
- info = &rss->data.info;
+ info = &rss->info->data.array;
desc = info->descriptor;
/* Make a new descriptor. */
tree maskindex;
tree mask;
tree pmask;
+ tree cycle_label = NULL_TREE;
int n;
int nvar;
int need_temp;
nvar = n;
/* Allocate the space for var, start, end, step, varexpr. */
- var = (tree *) gfc_getmem (nvar * sizeof (tree));
- start = (tree *) gfc_getmem (nvar * sizeof (tree));
- end = (tree *) gfc_getmem (nvar * sizeof (tree));
- step = (tree *) gfc_getmem (nvar * sizeof (tree));
- varexpr = (gfc_expr **) gfc_getmem (nvar * sizeof (gfc_expr *));
- saved_vars = (gfc_saved_var *) gfc_getmem (nvar * sizeof (gfc_saved_var));
+ var = XCNEWVEC (tree, nvar);
+ start = XCNEWVEC (tree, nvar);
+ end = XCNEWVEC (tree, nvar);
+ step = XCNEWVEC (tree, nvar);
+ varexpr = XCNEWVEC (gfc_expr *, nvar);
+ saved_vars = XCNEWVEC (gfc_saved_var, nvar);
/* Allocate the space for info. */
- info = (forall_info *) gfc_getmem (sizeof (forall_info));
+ info = XCNEW (forall_info);
gfc_start_block (&pre);
gfc_init_block (&post);
gfc_symbol *sym = fa->var->symtree->n.sym;
/* Allocate space for this_forall. */
- this_forall = (iter_info *) gfc_getmem (sizeof (iter_info));
+ this_forall = XCNEW (iter_info);
/* Create a temporary variable for the FORALL index. */
tmp = gfc_typenode_for_spec (&sym->ts);
gfc_add_expr_to_block (&block, tmp);
}
+ if (code->op == EXEC_DO_CONCURRENT)
+ {
+ gfc_init_block (&body);
+ cycle_label = gfc_build_label_decl (NULL_TREE);
+ code->cycle_label = cycle_label;
+ tmp = gfc_trans_code (code->block->next);
+ gfc_add_expr_to_block (&body, tmp);
+
+ if (TREE_USED (cycle_label))
+ {
+ tmp = build1_v (LABEL_EXPR, cycle_label);
+ gfc_add_expr_to_block (&body, tmp);
+ }
+
+ tmp = gfc_finish_block (&body);
+ tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
+ gfc_add_expr_to_block (&block, tmp);
+ goto done;
+ }
+
c = code->block->next;
/* TODO: loop merging in FORALL statements. */
c = c->next;
}
+done:
/* Restore the original index variables. */
for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++)
gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
/* Free the space for var, start, end, step, varexpr. */
- gfc_free (var);
- gfc_free (start);
- gfc_free (end);
- gfc_free (step);
- gfc_free (varexpr);
- gfc_free (saved_vars);
+ free (var);
+ free (start);
+ free (end);
+ free (step);
+ free (varexpr);
+ free (saved_vars);
for (this_forall = info->this_loop; this_forall;)
{
iter_info *next = this_forall->next;
- gfc_free (this_forall);
+ free (this_forall);
this_forall = next;
}
/* Free the space for this forall_info. */
- gfc_free (info);
+ free (info);
if (pmask)
{
}
+/* Translate the DO CONCURRENT construct. */
+
+tree gfc_trans_do_concurrent (gfc_code * code)
+{
+ return gfc_trans_forall_1 (code, NULL);
+}
+
+
/* Evaluate the WHERE mask expression, copy its value to a temporary.
If the WHERE construct is nested in FORALL, compute the overall temporary
needed by the WHERE mask expression multiplied by the iterator number of
/* Find a non-scalar SS from the lhs. */
while (lss_section != gfc_ss_terminator
- && lss_section->type != GFC_SS_SECTION)
+ && lss_section->info->type != GFC_SS_SECTION)
lss_section = lss_section->next;
gcc_assert (lss_section != gfc_ss_terminator);
/* Walk the rhs. */
rss = gfc_walk_expr (expr2);
if (rss == gfc_ss_terminator)
- {
- /* The rhs is scalar. Add a ss for the expression. */
- rss = gfc_get_ss ();
- rss->where = 1;
- rss->next = gfc_ss_terminator;
- rss->type = GFC_SS_SCALAR;
- rss->expr = expr2;
+ {
+ /* The rhs is scalar. Add a ss for the expression. */
+ rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
+ rss->info->where = 1;
}
/* Associate the SS with the loop. */
tsss = gfc_walk_expr (tsrc);
if (tsss == gfc_ss_terminator)
{
- tsss = gfc_get_ss ();
- tsss->where = 1;
- tsss->next = gfc_ss_terminator;
- tsss->type = GFC_SS_SCALAR;
- tsss->expr = tsrc;
+ tsss = gfc_get_scalar_ss (gfc_ss_terminator, tsrc);
+ tsss->info->where = 1;
}
gfc_add_ss_to_loop (&loop, tdss);
gfc_add_ss_to_loop (&loop, tsss);
esss = gfc_walk_expr (esrc);
if (esss == gfc_ss_terminator)
{
- esss = gfc_get_ss ();
- esss->where = 1;
- esss->next = gfc_ss_terminator;
- esss->type = GFC_SS_SCALAR;
- esss->expr = esrc;
+ esss = gfc_get_scalar_ss (gfc_ss_terminator, esrc);
+ esss->info->where = 1;
}
gfc_add_ss_to_loop (&loop, edss);
gfc_add_ss_to_loop (&loop, esss);
gfc_trans_allocate (gfc_code * code)
{
gfc_alloc *al;
+ gfc_expr *e;
gfc_expr *expr;
gfc_se se;
tree tmp;
tree parm;
tree stat;
- tree pstat;
- tree error_label;
+ tree errmsg;
+ tree errlen;
+ tree label_errmsg;
+ tree label_finish;
tree memsz;
tree expr3;
tree slen3;
stmtblock_t post;
gfc_expr *sz;
gfc_se se_sz;
+ tree class_expr;
+ tree nelems;
+ tree memsize = NULL_TREE;
+ tree classexpr = NULL_TREE;
if (!code->ext.alloc.list)
return NULL_TREE;
- pstat = stat = error_label = tmp = memsz = NULL_TREE;
+ stat = tmp = memsz = NULL_TREE;
+ label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
gfc_init_block (&block);
gfc_init_block (&post);
- /* Either STAT= and/or ERRMSG is present. */
- if (code->expr1 || code->expr2)
+ /* STAT= (and maybe ERRMSG=) is present. */
+ if (code->expr1)
{
+ /* STAT=. */
tree gfc_int4_type_node = gfc_get_int_type (4);
-
stat = gfc_create_var (gfc_int4_type_node, "stat");
- pstat = gfc_build_addr_expr (NULL_TREE, stat);
- error_label = gfc_build_label_decl (NULL_TREE);
- TREE_USED (error_label) = 1;
+ /* ERRMSG= only makes sense with STAT=. */
+ if (code->expr2)
+ {
+ gfc_init_se (&se, NULL);
+ se.want_pointer = 1;
+ gfc_conv_expr_lhs (&se, code->expr2);
+ errmsg = se.expr;
+ errlen = se.string_length;
+ }
+ else
+ {
+ errmsg = null_pointer_node;
+ errlen = build_int_cst (gfc_charlen_type_node, 0);
+ }
+
+ /* GOTO destinations. */
+ label_errmsg = gfc_build_label_decl (NULL_TREE);
+ label_finish = gfc_build_label_decl (NULL_TREE);
+ TREE_USED (label_finish) = 0;
}
expr3 = NULL_TREE;
se.descriptor_only = 1;
gfc_conv_expr (&se, expr);
- if (!gfc_array_allocate (&se, expr, pstat))
+ /* Evaluate expr3 just once if not a variable. */
+ if (al == code->ext.alloc.list
+ && al->expr->ts.type == BT_CLASS
+ && code->expr3
+ && code->expr3->ts.type == BT_CLASS
+ && code->expr3->expr_type != EXPR_VARIABLE)
+ {
+ gfc_init_se (&se_sz, NULL);
+ gfc_conv_expr_reference (&se_sz, code->expr3);
+ gfc_conv_class_to_class (&se_sz, code->expr3,
+ code->expr3->ts, false);
+ gfc_add_block_to_block (&se.pre, &se_sz.pre);
+ gfc_add_block_to_block (&se.post, &se_sz.post);
+ classexpr = build_fold_indirect_ref_loc (input_location,
+ se_sz.expr);
+ classexpr = gfc_evaluate_now (classexpr, &se.pre);
+ memsize = gfc_vtable_size_get (classexpr);
+ memsize = fold_convert (sizetype, memsize);
+ }
+
+ memsz = memsize;
+ class_expr = classexpr;
+
+ nelems = NULL_TREE;
+ if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish,
+ memsz, &nelems, code->expr3))
{
/* A scalar or derived type. */
/* Determine allocate size. */
- if (al->expr->ts.type == BT_CLASS && code->expr3)
+ if (al->expr->ts.type == BT_CLASS
+ && code->expr3
+ && memsz == NULL_TREE)
{
if (code->expr3->ts.type == BT_CLASS)
{
|| code->expr3->expr_type == EXPR_CONSTANT)
{
gfc_conv_expr (&se_sz, code->expr3);
+ gfc_add_block_to_block (&se.pre, &se_sz.pre);
+ se_sz.string_length
+ = gfc_evaluate_now (se_sz.string_length, &se.pre);
+ gfc_add_block_to_block (&se.pre, &se_sz.post);
memsz = se_sz.string_length;
}
else if (code->expr3->mold
TREE_TYPE (tmp), tmp,
fold_convert (TREE_TYPE (tmp), memsz));
}
+ else if (al->expr->ts.type == BT_CHARACTER && al->expr->ts.deferred)
+ {
+ gcc_assert (code->ext.alloc.ts.u.cl && code->ext.alloc.ts.u.cl->length);
+ gfc_init_se (&se_sz, NULL);
+ gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
+ gfc_add_block_to_block (&se.pre, &se_sz.pre);
+ se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
+ gfc_add_block_to_block (&se.pre, &se_sz.post);
+ /* Store the string length. */
+ tmp = al->expr->ts.u.cl->backend_decl;
+ gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
+ se_sz.expr));
+ tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts));
+ tmp = TYPE_SIZE_UNIT (tmp);
+ memsz = fold_build2_loc (input_location, MULT_EXPR,
+ TREE_TYPE (tmp), tmp,
+ fold_convert (TREE_TYPE (se_sz.expr),
+ se_sz.expr));
+ }
else if (code->ext.alloc.ts.type != BT_UNKNOWN)
memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
- else
+ else if (memsz == NULL_TREE)
memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE)
/* Allocate - for non-pointers with re-alloc checking. */
if (gfc_expr_attr (expr).allocatable)
- tmp = gfc_allocate_array_with_status (&se.pre, se.expr, memsz,
- pstat, expr);
+ gfc_allocate_allocatable (&se.pre, se.expr, memsz, NULL_TREE,
+ stat, errmsg, errlen, label_finish, expr);
else
- tmp = gfc_allocate_with_status (&se.pre, memsz, pstat);
-
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
- se.expr,
- fold_convert (TREE_TYPE (se.expr), tmp));
- gfc_add_expr_to_block (&se.pre, tmp);
+ gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat);
- if (code->expr1 || code->expr2)
+ if (al->expr->ts.type == BT_DERIVED
+ && expr->ts.u.derived->attr.alloc_comp)
{
- tmp = build1_v (GOTO_EXPR, error_label);
- parm = fold_build2_loc (input_location, NE_EXPR,
- boolean_type_node, stat,
- build_int_cst (TREE_TYPE (stat), 0));
- tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
- parm, tmp,
- build_empty_stmt (input_location));
+ tmp = build_fold_indirect_ref_loc (input_location, se.expr);
+ tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0);
gfc_add_expr_to_block (&se.pre, tmp);
}
-
- if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
+ else if (al->expr->ts.type == BT_CLASS)
{
- tmp = build_fold_indirect_ref_loc (input_location, se.expr);
- tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0);
+ /* With class objects, it is best to play safe and null the
+ memory because we cannot know if dynamic types have allocatable
+ components or not. */
+ tmp = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_MEMSET),
+ 3, se.expr, integer_zero_node, memsz);
gfc_add_expr_to_block (&se.pre, tmp);
}
}
gfc_add_block_to_block (&block, &se.pre);
+ /* Error checking -- Note: ERRMSG only makes sense with STAT. */
+ if (code->expr1)
+ {
+ tmp = build1_v (GOTO_EXPR, label_errmsg);
+ parm = fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node, stat,
+ build_int_cst (TREE_TYPE (stat), 0));
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ gfc_unlikely (parm), tmp,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, tmp);
+ }
+
+ /* We need the vptr of CLASS objects to be initialized. */
+ e = gfc_copy_expr (al->expr);
+ if (e->ts.type == BT_CLASS)
+ {
+ gfc_expr *lhs, *rhs;
+ gfc_se lse;
+
+ lhs = gfc_expr_to_initialize (e);
+ gfc_add_vptr_component (lhs);
+
+ if (class_expr != NULL_TREE)
+ {
+ /* Polymorphic SOURCE: VPTR must be determined at run time. */
+ gfc_init_se (&lse, NULL);
+ lse.want_pointer = 1;
+ gfc_conv_expr (&lse, lhs);
+ tmp = gfc_class_vptr_get (class_expr);
+ gfc_add_modify (&block, lse.expr,
+ fold_convert (TREE_TYPE (lse.expr), tmp));
+ }
+ else 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_vptr_component (rhs);
+ tmp = gfc_trans_pointer_assignment (lhs, rhs);
+ gfc_add_expr_to_block (&block, tmp);
+ gfc_free_expr (rhs);
+ rhs = gfc_expr_to_initialize (e);
+ }
+ else
+ {
+ /* VPTR is fixed at compile time. */
+ gfc_symbol *vtab;
+ gfc_typespec *ts;
+ if (code->expr3)
+ ts = &code->expr3->ts;
+ else if (e->ts.type == BT_DERIVED)
+ ts = &e->ts;
+ else if (code->ext.alloc.ts.type == BT_DERIVED)
+ ts = &code->ext.alloc.ts;
+ else if (e->ts.type == BT_CLASS)
+ ts = &CLASS_DATA (e)->ts;
+ else
+ ts = &e->ts;
+
+ if (ts->type == BT_DERIVED)
+ {
+ vtab = gfc_find_derived_vtab (ts->u.derived);
+ gcc_assert (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));
+ }
+ }
+ gfc_free_expr (lhs);
+ }
+
+ gfc_free_expr (e);
+
if (code->expr3 && !code->expr3->mold)
{
/* Initialization via SOURCE block
(or static default initializer). */
gfc_expr *rhs = gfc_copy_expr (code->expr3);
- if (al->expr->ts.type == BT_CLASS)
+ if (class_expr != NULL_TREE)
+ {
+ tree to;
+ to = TREE_OPERAND (se.expr, 0);
+
+ tmp = gfc_copy_class_to_class (class_expr, to, nelems);
+ }
+ else if (al->expr->ts.type == BT_CLASS)
{
- gfc_se call;
gfc_actual_arglist *actual;
gfc_expr *ppc;
- gfc_init_se (&call, NULL);
+ gfc_code *ppc_code;
+ gfc_ref *dataref;
+
/* Do a polymorphic deep copy. */
actual = gfc_get_actual_arglist ();
actual->expr = gfc_copy_expr (rhs);
gfc_add_data_component (actual->expr);
actual->next = gfc_get_actual_arglist ();
actual->next->expr = gfc_copy_expr (al->expr);
+ actual->next->expr->ts.type = BT_CLASS;
gfc_add_data_component (actual->next->expr);
+
+ dataref = actual->next->expr->ref;
+ /* Make sure we go up through the reference chain to
+ the _data reference, where the arrayspec is found. */
+ while (dataref->next && dataref->next->type != REF_ARRAY)
+ dataref = dataref->next;
+
+ if (dataref->u.c.component->as)
+ {
+ int dim;
+ gfc_expr *temp;
+ gfc_ref *ref = dataref->next;
+ ref->u.ar.type = AR_SECTION;
+ /* We have to set up the array reference to give ranges
+ in all dimensions and ensure that the end and stride
+ are set so that the copy can be scalarized. */
+ dim = 0;
+ for (; dim < dataref->u.c.component->as->rank; dim++)
+ {
+ ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
+ if (ref->u.ar.end[dim] == NULL)
+ {
+ ref->u.ar.end[dim] = ref->u.ar.start[dim];
+ temp = gfc_get_int_expr (gfc_default_integer_kind,
+ &al->expr->where, 1);
+ ref->u.ar.start[dim] = temp;
+ }
+ temp = gfc_subtract (gfc_copy_expr (ref->u.ar.end[dim]),
+ gfc_copy_expr (ref->u.ar.start[dim]));
+ temp = gfc_add (gfc_get_int_expr (gfc_default_integer_kind,
+ &al->expr->where, 1),
+ temp);
+ }
+ }
if (rhs->ts.type == BT_CLASS)
{
ppc = gfc_copy_expr (rhs);
gfc_add_vptr_component (ppc);
}
else
- ppc = gfc_lval_expr_from_sym (gfc_find_derived_vtab (rhs->ts.u.derived));
+ ppc = gfc_lval_expr_from_sym
+ (gfc_find_derived_vtab (rhs->ts.u.derived));
gfc_add_component_ref (ppc, "_copy");
- gfc_conv_procedure_call (&call, ppc->symtree->n.sym, actual,
- ppc, NULL);
- gfc_add_expr_to_block (&call.pre, call.expr);
- gfc_add_block_to_block (&call.pre, &call.post);
- tmp = gfc_finish_block (&call.pre);
+
+ ppc_code = gfc_get_code ();
+ ppc_code->resolved_sym = ppc->symtree->n.sym;
+ /* Although '_copy' is set to be elemental in class.c, it is
+ not staying that way. Find out why, sometime.... */
+ ppc_code->resolved_sym->attr.elemental = 1;
+ ppc_code->ext.actual = actual;
+ ppc_code->expr1 = ppc;
+ ppc_code->op = EXEC_CALL;
+ /* Since '_copy' is elemental, the scalarizer will take care
+ of arrays in gfc_trans_call. */
+ tmp = gfc_trans_call (ppc_code, true, NULL, NULL, false);
+ gfc_free_statements (ppc_code);
}
else if (expr3 != NULL_TREE)
{
gfc_free_expr (rhs);
gfc_add_expr_to_block (&block, tmp);
}
- else if (code->expr3 && code->expr3->mold
+ else if (code->expr3 && code->expr3->mold
&& code->expr3->ts.type == BT_CLASS)
{
- /* Default-initialization via MOLD (polymorphic). */
- gfc_expr *rhs = gfc_copy_expr (code->expr3);
- gfc_se dst,src;
- gfc_add_vptr_component (rhs);
- gfc_add_def_init_component (rhs);
- 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);
+ /* Since the _vptr has already been assigned to the allocate
+ object, we can use gfc_copy_class_to_class in its
+ initialization mode. */
+ tmp = TREE_OPERAND (se.expr, 0);
+ tmp = gfc_copy_class_to_class (NULL_TREE, tmp, nelems);
gfc_add_expr_to_block (&block, tmp);
- gfc_free_expr (rhs);
- }
-
- /* 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_vptr_component (lhs);
- 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_vptr_component (rhs);
- 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);
- gcc_assert (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));
- }
- }
- gfc_free_expr (lhs);
}
+ gfc_free_expr (expr);
}
- /* STAT block. */
+ /* STAT. */
if (code->expr1)
{
- tmp = build1_v (LABEL_EXPR, error_label);
+ tmp = build1_v (LABEL_EXPR, label_errmsg);
gfc_add_expr_to_block (&block, tmp);
-
- gfc_init_se (&se, NULL);
- gfc_conv_expr_lhs (&se, code->expr1);
- tmp = convert (TREE_TYPE (se.expr), stat);
- gfc_add_modify (&block, se.expr, tmp);
}
- /* ERRMSG block. */
- if (code->expr2)
+ /* ERRMSG - only useful if STAT is present. */
+ if (code->expr1 && code->expr2)
{
- /* A better error message may be possible, but not required. */
const char *msg = "Attempt to allocate an allocated object";
- tree errmsg, slen, dlen;
+ tree slen, dlen, errmsg_str;
+ stmtblock_t errmsg_block;
- gfc_init_se (&se, NULL);
- gfc_conv_expr_lhs (&se, code->expr2);
-
- errmsg = gfc_create_var (pchar_type_node, "ERRMSG");
+ gfc_init_block (&errmsg_block);
- gfc_add_modify (&block, errmsg,
+ errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG");
+ gfc_add_modify (&errmsg_block, errmsg_str,
gfc_build_addr_expr (pchar_type_node,
gfc_build_localized_cstring_const (msg)));
slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen,
slen);
- dlen = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MEMCPY], 3,
- gfc_build_addr_expr (pvoid_type_node, se.expr), errmsg, slen);
+ gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind,
+ slen, errmsg_str, gfc_default_character_kind);
+ dlen = gfc_finish_block (&errmsg_block);
tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
build_int_cst (TREE_TYPE (stat), 0));
gfc_add_expr_to_block (&block, tmp);
}
+ /* STAT block. */
+ if (code->expr1)
+ {
+ if (TREE_USED (label_finish))
+ {
+ tmp = build1_v (LABEL_EXPR, label_finish);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_lhs (&se, code->expr1);
+ tmp = convert (TREE_TYPE (se.expr), stat);
+ gfc_add_modify (&block, se.expr, tmp);
+ }
+
gfc_add_block_to_block (&block, &se.post);
gfc_add_block_to_block (&block, &post);
{
gfc_se se;
gfc_alloc *al;
- tree apstat, astat, pstat, stat, tmp;
+ tree apstat, pstat, stat, errmsg, errlen, tmp;
+ tree label_finish, label_errmsg;
stmtblock_t block;
- pstat = apstat = stat = astat = tmp = NULL_TREE;
+ pstat = apstat = stat = errmsg = errlen = tmp = NULL_TREE;
+ label_finish = label_errmsg = NULL_TREE;
gfc_start_block (&block);
/* Count the number of failed deallocations. If deallocate() was
called with STAT= , then set STAT to the count. If deallocate
was called with ERRMSG, then set ERRMG to a string. */
- if (code->expr1 || code->expr2)
+ if (code->expr1)
{
tree gfc_int4_type_node = gfc_get_int_type (4);
stat = gfc_create_var (gfc_int4_type_node, "stat");
pstat = gfc_build_addr_expr (NULL_TREE, stat);
- /* Running total of possible deallocation failures. */
- astat = gfc_create_var (gfc_int4_type_node, "astat");
- apstat = gfc_build_addr_expr (NULL_TREE, astat);
+ /* GOTO destinations. */
+ label_errmsg = gfc_build_label_decl (NULL_TREE);
+ label_finish = gfc_build_label_decl (NULL_TREE);
+ TREE_USED (label_finish) = 0;
+ }
- /* Initialize astat to 0. */
- gfc_add_modify (&block, astat, build_int_cst (TREE_TYPE (astat), 0));
+ /* Set ERRMSG - only needed if STAT is available. */
+ if (code->expr1 && code->expr2)
+ {
+ gfc_init_se (&se, NULL);
+ se.want_pointer = 1;
+ gfc_conv_expr_lhs (&se, code->expr2);
+ errmsg = se.expr;
+ errlen = se.string_length;
}
for (al = code->ext.alloc.list; al != NULL; al = al->next)
se.descriptor_only = 1;
gfc_conv_expr (&se, expr);
- if (expr->rank)
+ if (expr->rank || gfc_is_coarray (expr))
{
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
{
gfc_add_expr_to_block (&se.pre, tmp);
}
}
- tmp = gfc_array_deallocate (se.expr, pstat, expr);
+ tmp = gfc_array_deallocate (se.expr, pstat, errmsg, errlen,
+ label_finish, expr);
gfc_add_expr_to_block (&se.pre, tmp);
}
else
}
}
- /* Keep track of the number of failed deallocations by adding stat
- of the last deallocation to the running total. */
- if (code->expr1 || code->expr2)
+ if (code->expr1)
{
- apstat = fold_build2_loc (input_location, PLUS_EXPR,
- TREE_TYPE (stat), astat, stat);
- gfc_add_modify (&se.pre, astat, apstat);
+ tree cond;
+
+ cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
+ build_int_cst (TREE_TYPE (stat), 0));
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ gfc_unlikely (cond),
+ build1_v (GOTO_EXPR, label_errmsg),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&se.pre, tmp);
}
tmp = gfc_finish_block (&se.pre);
gfc_free_expr (expr);
}
- /* Set STAT. */
if (code->expr1)
{
- gfc_init_se (&se, NULL);
- gfc_conv_expr_lhs (&se, code->expr1);
- tmp = convert (TREE_TYPE (se.expr), astat);
- gfc_add_modify (&block, se.expr, tmp);
+ tmp = build1_v (LABEL_EXPR, label_errmsg);
+ gfc_add_expr_to_block (&block, tmp);
}
- /* Set ERRMSG. */
- if (code->expr2)
+ /* Set ERRMSG - only needed if STAT is available. */
+ if (code->expr1 && code->expr2)
{
- /* A better error message may be possible, but not required. */
const char *msg = "Attempt to deallocate an unallocated object";
- tree errmsg, slen, dlen;
-
- gfc_init_se (&se, NULL);
- gfc_conv_expr_lhs (&se, code->expr2);
+ stmtblock_t errmsg_block;
+ tree errmsg_str, slen, dlen, cond;
- errmsg = gfc_create_var (pchar_type_node, "ERRMSG");
+ gfc_init_block (&errmsg_block);
- gfc_add_modify (&block, errmsg,
+ errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG");
+ gfc_add_modify (&errmsg_block, errmsg_str,
gfc_build_addr_expr (pchar_type_node,
gfc_build_localized_cstring_const (msg)));
-
slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
dlen = gfc_get_expr_charlen (code->expr2);
- slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen,
- slen);
- dlen = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MEMCPY], 3,
- gfc_build_addr_expr (pvoid_type_node, se.expr), errmsg, slen);
+ gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind,
+ slen, errmsg_str, gfc_default_character_kind);
+ tmp = gfc_finish_block (&errmsg_block);
- tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, astat,
- build_int_cst (TREE_TYPE (astat), 0));
+ cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
+ build_int_cst (TREE_TYPE (stat), 0));
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ gfc_unlikely (cond), tmp,
+ build_empty_stmt (input_location));
- tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ if (code->expr1 && TREE_USED (label_finish))
+ {
+ tmp = build1_v (LABEL_EXPR, label_finish);
gfc_add_expr_to_block (&block, tmp);
}
+ /* Set STAT. */
+ if (code->expr1)
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_lhs (&se, code->expr1);
+ tmp = convert (TREE_TYPE (se.expr), stat);
+ gfc_add_modify (&block, se.expr, tmp);
+ }
+
return gfc_finish_block (&block);
}
OSDN Git Service
