/* Expression translation
- Copyright (C) 2002-2016 Free Software Foundation, Inc.
+ Copyright (C) 2002-2017 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
"component at %L is not supported", &expr->where);
}
- caf_decl = expr->symtree->n.sym->backend_decl;
- gcc_assert (caf_decl);
+ /* Make sure the backend_decl is present before accessing it. */
+ caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
+ ? gfc_get_symbol_decl (expr->symtree->n.sym)
+ : expr->symtree->n.sym->backend_decl;
+
if (expr->symtree->n.sym->ts.type == BT_CLASS)
{
if (expr->ref && expr->ref->type == REF_ARRAY)
msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
"is less than one", name);
else
- msg = xasprintf ("Substring out of bounds: lower bound (%%ld)"
+ msg = xasprintf ("Substring out of bounds: lower bound (%%ld) "
"is less than one");
gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
fold_convert (long_integer_type_node,
if (se_expr)
se->expr = se_expr;
- /* Procedure actual arguments. */
- else if (sym->attr.flavor == FL_PROCEDURE
+ /* Procedure actual arguments. Look out for temporary variables
+ with the same attributes as function values. */
+ else if (!sym->attr.temporary
+ && sym->attr.flavor == FL_PROCEDURE
&& se->expr != current_function_decl)
{
if (!sym->attr.dummy && !sym->attr.proc_pointer)
return 0;
m = wrhs.to_shwi ();
- /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
- of the asymmetric range of the integer type. */
- n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
+ /* Use the wide_int's routine to reliably get the absolute value on all
+ platforms. Then convert it to a HOST_WIDE_INT like above. */
+ n = wi::abs (wrhs).to_shwi ();
type = TREE_TYPE (lhs);
sgn = tree_int_cst_sgn (rhs);
if (fsym && fsym->attr.allocatable
&& fsym->attr.intent == INTENT_OUT)
{
+ if (fsym->ts.type == BT_DERIVED
+ && fsym->ts.u.derived->attr.alloc_comp)
+ {
+ // deallocate the components first
+ tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
+ parmse.expr, e->rank);
+ if (tmp != NULL_TREE)
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
+
tmp = build_fold_indirect_ref_loc (input_location,
parmse.expr);
- tmp = gfc_trans_dealloc_allocated (tmp, e,
- GFC_CAF_COARRAY_NOCOARRAY);
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+ tmp = gfc_conv_descriptor_data_get (tmp);
+ tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
+ NULL_TREE, NULL_TREE, true,
+ e,
+ GFC_CAF_COARRAY_NOCOARRAY);
if (fsym->attr.optional
&& e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.optional)
type = gfc_get_character_type (ts.kind, ts.u.cl);
type = build_pointer_type (type);
+ /* Emit a DECL_EXPR for the VLA type. */
+ tmp = TREE_TYPE (type);
+ if (TYPE_SIZE (tmp)
+ && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
+ {
+ tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
+ DECL_ARTIFICIAL (tmp) = 1;
+ DECL_IGNORED_P (tmp) = 1;
+ tmp = fold_build1_loc (input_location, DECL_EXPR,
+ TREE_TYPE (tmp), tmp);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
+
/* Return an address to a char[0:len-1]* temporary for
character pointers. */
if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
after use. This necessitates the creation of a temporary to
hold the result to prevent duplicate calls. */
if (!byref && sym->ts.type != BT_CHARACTER
- && sym->attr.allocatable && !sym->attr.dimension)
+ && ((sym->attr.allocatable && !sym->attr.dimension && !comp)
+ || (comp && comp->attr.allocatable && !comp->attr.dimension)))
{
tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
gfc_add_modify (&se->pre, tmp, se->expr);
gfc_add_block_to_block (&se->pre, &post);
/* Transformational functions of derived types with allocatable
- components must have the result allocatable components copied. */
+ components must have the result allocatable components copied when the
+ argument is actually given. */
arg = expr->value.function.actual;
if (result && arg && expr->rank
- && expr->value.function.isym
- && expr->value.function.isym->transformational
- && arg->expr->ts.type == BT_DERIVED
- && arg->expr->ts.u.derived->attr.alloc_comp)
+ && expr->value.function.isym
+ && expr->value.function.isym->transformational
+ && arg->expr
+ && arg->expr->ts.type == BT_DERIVED
+ && arg->expr->ts.u.derived->attr.alloc_comp)
{
tree tmp2;
/* Copy the allocatable components. We have to use a
return;
}
+ /* The string copy algorithm below generates code like
+
+ if (dlen > 0) {
+ memmove (dest, src, min(dlen, slen));
+ if (slen < dlen)
+ memset(&dest[slen], ' ', dlen - slen);
+ }
+ */
+
/* Do nothing if the destination length is zero. */
cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, dlen,
build_int_cst (size_type_node, 0));
- /* The following code was previously in _gfortran_copy_string:
-
- // The two strings may overlap so we use memmove.
- void
- copy_string (GFC_INTEGER_4 destlen, char * dest,
- GFC_INTEGER_4 srclen, const char * src)
- {
- if (srclen >= destlen)
- {
- // This will truncate if too long.
- memmove (dest, src, destlen);
- }
- else
- {
- memmove (dest, src, srclen);
- // Pad with spaces.
- memset (&dest[srclen], ' ', destlen - srclen);
- }
- }
-
- We're now doing it here for better optimization, but the logic
- is the same. */
-
/* For non-default character kinds, we have to multiply the string
length by the base type size. */
chartype = gfc_get_char_type (dkind);
else
src = gfc_build_addr_expr (pvoid_type_node, src);
- /* Truncate string if source is too long. */
- cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen,
- dlen);
+ /* First do the memmove. */
+ tmp2 = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (dlen), dlen,
+ slen);
tmp2 = build_call_expr_loc (input_location,
builtin_decl_explicit (BUILT_IN_MEMMOVE),
- 3, dest, src, dlen);
+ 3, dest, src, tmp2);
+ stmtblock_t tmpblock2;
+ gfc_init_block (&tmpblock2);
+ gfc_add_expr_to_block (&tmpblock2, tmp2);
- /* Else copy and pad with spaces. */
- tmp3 = build_call_expr_loc (input_location,
- builtin_decl_explicit (BUILT_IN_MEMMOVE),
- 3, dest, src, slen);
+ /* If the destination is longer, fill the end with spaces. */
+ cond2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, slen,
+ dlen);
/* Wstringop-overflow appears at -O3 even though this warning is not
explicitly available in fortran nor can it be switched off. If the
tmp4 = fill_with_spaces (tmp4, chartype, tmp);
gfc_init_block (&tempblock);
- gfc_add_expr_to_block (&tempblock, tmp3);
gfc_add_expr_to_block (&tempblock, tmp4);
tmp3 = gfc_finish_block (&tempblock);
/* The whole copy_string function is there. */
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
- tmp2, tmp3);
+ tmp3, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&tmpblock2, tmp);
+ tmp = gfc_finish_block (&tmpblock2);
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
build_empty_stmt (input_location));
gfc_add_expr_to_block (block, tmp);
{
if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
- else if (cm->attr.allocatable)
+ else if (cm->attr.allocatable || cm->attr.pdt_array)
{
tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
gfc_add_expr_to_block (&block, tmp);
Register only allocatable components, that are not coarray'ed
components (%comp[*]). Only register when the constructor is not the
null-expression. */
- if (coarray && !cm->attr.codimension && cm->attr.allocatable
+ if (coarray && !cm->attr.codimension
+ && (cm->attr.allocatable || cm->attr.pointer)
&& (!c->expr || c->expr->expr_type == EXPR_NULL))
{
tree token, desc, size;
- symbol_attribute attr;
bool is_array = cm->ts.type == BT_CLASS
? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
}
else
{
- desc = gfc_conv_scalar_to_descriptor (&se, field, attr);
+ desc = gfc_conv_scalar_to_descriptor (&se, field,
+ cm->ts.type == BT_CLASS
+ ? CLASS_DATA (cm)->attr
+ : cm->attr);
size = TYPE_SIZE_UNIT (TREE_TYPE (field));
}
gfc_add_block_to_block (&block, &se.pre);
return lhs_vptr;
}
+
+/* Assign tokens for pointer components. */
+
+static void
+trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
+ gfc_expr *expr2)
+{
+ symbol_attribute lhs_attr, rhs_attr;
+ tree tmp, lhs_tok, rhs_tok;
+ /* Flag to indicated component refs on the rhs. */
+ bool rhs_cr;
+
+ lhs_attr = gfc_caf_attr (expr1);
+ if (expr2->expr_type != EXPR_NULL)
+ {
+ rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
+ if (lhs_attr.codimension && rhs_attr.codimension)
+ {
+ lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
+ lhs_tok = build_fold_indirect_ref (lhs_tok);
+
+ if (rhs_cr)
+ rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
+ else
+ {
+ tree caf_decl;
+ caf_decl = gfc_get_tree_for_caf_expr (expr2);
+ gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
+ NULL_TREE, NULL);
+ }
+ tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
+ lhs_tok,
+ fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
+ gfc_prepend_expr_to_block (&lse->post, tmp);
+ }
+ }
+ else if (lhs_attr.codimension)
+ {
+ lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
+ lhs_tok = build_fold_indirect_ref (lhs_tok);
+ tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
+ lhs_tok, null_pointer_node);
+ gfc_prepend_expr_to_block (&lse->post, tmp);
+ }
+}
+
/* Indentify class valued proc_pointer assignments. */
static bool
gfc_add_modify (&block, lse.expr,
fold_convert (TREE_TYPE (lse.expr), rse.expr));
+ /* Also set the tokens for pointer components in derived typed
+ coarrays. */
+ if (flag_coarray == GFC_FCOARRAY_LIB)
+ trans_caf_token_assign (&lse, &rse, expr1, expr2);
+
gfc_add_block_to_block (&block, &rse.post);
gfc_add_block_to_block (&block, &lse.post);
}
static tree
trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
- gfc_se *lse, gfc_se *rse, bool use_vptr_copy)
+ gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
+ bool class_realloc)
{
- tree tmp;
- tree fcn;
- tree stdcopy, to_len, from_len;
+ tree tmp, fcn, stdcopy, to_len, from_len, vptr;
vec<tree, va_gc> *args = NULL;
- tmp = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
+ vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
&from_len);
- fcn = gfc_vptr_copy_get (tmp);
+ /* Generate allocation of the lhs. */
+ if (class_realloc)
+ {
+ stmtblock_t alloc;
+ tree class_han;
+
+ tmp = gfc_vptr_size_get (vptr);
+ class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
+ ? gfc_class_data_get (lse->expr) : lse->expr;
+ gfc_init_block (&alloc);
+ gfc_allocate_using_malloc (&alloc, class_han, tmp, NULL_TREE);
+ tmp = fold_build2_loc (input_location, EQ_EXPR,
+ boolean_type_node, class_han,
+ build_int_cst (prvoid_type_node, 0));
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ gfc_unlikely (tmp,
+ PRED_FORTRAN_FAIL_ALLOC),
+ gfc_finish_block (&alloc),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&lse->pre, tmp);
+ }
+
+ fcn = gfc_vptr_copy_get (vptr);
tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
? gfc_class_data_get (rse->expr) : rse->expr;
bool scalar_to_array;
tree string_length;
int n;
- bool maybe_workshare = false;
+ bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
bool is_poly_assign;
mode. */
if (flag_coarray == GFC_FCOARRAY_LIB)
{
- lhs_caf_attr = gfc_caf_attr (expr1);
- rhs_caf_attr = gfc_caf_attr (expr2);
+ lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp);
+ rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
}
if (lss != gfc_ss_terminator)
tree cond;
const char* msg;
+ tmp = INDIRECT_REF_P (lse.expr)
+ ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
+
/* We should only get array references here. */
- gcc_assert (TREE_CODE (lse.expr) == POINTER_PLUS_EXPR
- || TREE_CODE (lse.expr) == ARRAY_REF);
+ gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
+ || TREE_CODE (tmp) == ARRAY_REF);
/* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
or the array itself(ARRAY_REF). */
- tmp = TREE_OPERAND (lse.expr, 0);
+ tmp = TREE_OPERAND (tmp, 0);
/* Provide the address of the array. */
if (TREE_CODE (lse.expr) == ARRAY_REF)
}
if (is_poly_assign)
- {
- tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
- use_vptr_copy || (lhs_attr.allocatable
- && !lhs_attr.dimension));
- /* Modify the expr1 after the assignment, to allow the realloc below.
- Therefore only needed, when realloc_lhs is enabled. */
- if (flag_realloc_lhs && !lhs_attr.pointer)
- gfc_add_data_component (expr1);
- }
+ tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
+ use_vptr_copy || (lhs_attr.allocatable
+ && !lhs_attr.dimension),
+ flag_realloc_lhs && !lhs_attr.pointer);
else if (flag_coarray == GFC_FCOARRAY_LIB
&& lhs_caf_attr.codimension && rhs_caf_attr.codimension
- && lhs_caf_attr.alloc_comp && rhs_caf_attr.alloc_comp)
+ && ((lhs_caf_attr.allocatable && lhs_refs_comp)
+ || (rhs_caf_attr.allocatable && rhs_refs_comp)))
{
+ /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
+ allocatable component, because those need to be accessed via the
+ caf-runtime. No need to check for coindexes here, because resolve
+ has rewritten those already. */
gfc_code code;
gfc_actual_arglist a1, a2;
+ /* Clear the structures to prevent accessing garbage. */
+ memset (&code, '\0', sizeof (gfc_code));
+ memset (&a1, '\0', sizeof (gfc_actual_arglist));
+ memset (&a2, '\0', sizeof (gfc_actual_arglist));
a1.expr = expr1;
a1.next = &a2;
a2.expr = expr2;
if (lss == gfc_ss_terminator)
{
/* F2003: Add the code for reallocation on assignment. */
- if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1))
+ if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
+ && !is_poly_assign)
alloc_scalar_allocatable_for_assignment (&block, string_length,
expr1, expr2);
projects / gcc.git / blobdiff