/* Expression translation
- Copyright (C) 2002-2018 Free Software Foundation, Inc.
+ Copyright (C) 2002-2019 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
of refs following. */
gfc_expr *
-gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
+gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold)
{
gfc_expr *base_expr;
gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
e->ref = NULL;
}
- base_expr = gfc_expr_to_initialize (e);
+ if (is_mold)
+ base_expr = gfc_expr_to_initialize (e);
+ else
+ base_expr = gfc_copy_expr (e);
/* Restore the original tail expression. */
if (class_ref)
}
-/* Obtain the vptr of the last class reference in an expression.
+/* Obtain the last class reference in an expression.
Return NULL_TREE if no class reference is found. */
tree
-gfc_get_vptr_from_expr (tree expr)
+gfc_get_class_from_expr (tree expr)
{
tree tmp;
tree type;
while (type)
{
if (GFC_CLASS_TYPE_P (type))
- return gfc_class_vptr_get (tmp);
+ return tmp;
if (type != TYPE_CANONICAL (type))
type = TYPE_CANONICAL (type);
else
tmp = build_fold_indirect_ref_loc (input_location, tmp);
if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
+ return tmp;
+
+ return NULL_TREE;
+}
+
+
+/* Obtain the vptr of the last class reference in an expression.
+ Return NULL_TREE if no class reference is found. */
+
+tree
+gfc_get_vptr_from_expr (tree expr)
+{
+ tree tmp;
+
+ tmp = gfc_get_class_from_expr (expr);
+
+ if (tmp != NULL_TREE)
return gfc_class_vptr_get (tmp);
return NULL_TREE;
}
else
{
- gfc_error ("Can't compute the length of the char array at %L.",
- &e->where);
+ gfc_error ("Cannot compute the length of the char array "
+ "at %L.", &e->where);
}
}
}
/* Return the len component, except in the case of scalarized array
references, where the dynamic type cannot change. */
- if (!elemental && full_array && copyback)
+ if (!elemental && full_array && copyback
+ && (UNLIMITED_POLY (e) || VAR_P (tmp)))
gfc_add_modify (&parmse->post, tmp,
fold_convert (TREE_TYPE (tmp), ctree));
}
gfc_start_block (&block);
lhs = gfc_copy_expr (code->expr1);
- gfc_add_data_component (lhs);
rhs = gfc_copy_expr (code->expr1);
gfc_add_vptr_component (rhs);
{
gfc_array_spec *tmparr = gfc_get_array_spec ();
*tmparr = *CLASS_DATA (code->expr1)->as;
+ /* Adding the array ref to the class expression results in correct
+ indexing to the dynamic type. */
gfc_add_full_array_ref (lhs, tmparr);
tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
}
else
{
+ /* Scalar initialization needs the _data component. */
+ gfc_add_data_component (lhs);
sz = gfc_copy_expr (code->expr1);
gfc_add_vptr_component (sz);
gfc_add_size_component (sz);
{
gfc_ref *r;
tree length;
+ gfc_se se;
gcc_assert (e->expr_type == EXPR_VARIABLE
&& e->ts.type == BT_CHARACTER);
/* Do nothing. */
break;
+ case REF_SUBSTRING:
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_type (&se, r->u.ss.start, gfc_charlen_type_node);
+ length = se.expr;
+ gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node);
+ length = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_charlen_type_node,
+ se.expr, length);
+ length = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_charlen_type_node, length,
+ gfc_index_one_node);
+ break;
+
default:
- /* We should never got substring references here. These will be
- broken down by the scalarizer. */
gcc_unreachable ();
break;
}
integer_zero_node);
}
- img_idx = integer_zero_node;
- extent = integer_one_node;
+ img_idx = build_zero_cst (gfc_array_index_type);
+ extent = build_one_cst (gfc_array_index_type);
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
{
gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, ref->u.ar.start[i], integer_type_node);
+ gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
gfc_add_block_to_block (block, &se.pre);
lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
- integer_type_node, se.expr,
- fold_convert(integer_type_node, lbound));
- tmp = fold_build2_loc (input_location, MULT_EXPR, integer_type_node,
+ TREE_TYPE (lbound), se.expr, lbound);
+ tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
extent, tmp);
- img_idx = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
- img_idx, tmp);
+ img_idx = fold_build2_loc (input_location, PLUS_EXPR,
+ TREE_TYPE (tmp), img_idx, tmp);
if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
{
ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
- tmp = fold_convert (integer_type_node, tmp);
extent = fold_build2_loc (input_location, MULT_EXPR,
- integer_type_node, extent, tmp);
+ TREE_TYPE (tmp), extent, tmp);
}
}
else
for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
{
gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, ref->u.ar.start[i], integer_type_node);
+ gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
gfc_add_block_to_block (block, &se.pre);
lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i);
- lbound = fold_convert (integer_type_node, lbound);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
- integer_type_node, se.expr, lbound);
- tmp = fold_build2_loc (input_location, MULT_EXPR, integer_type_node,
+ TREE_TYPE (lbound), se.expr, lbound);
+ tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
extent, tmp);
- img_idx = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
+ img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
img_idx, tmp);
if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
{
ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i);
- ubound = fold_convert (integer_type_node, ubound);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
- integer_type_node, ubound, lbound);
- tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
- tmp, integer_one_node);
+ TREE_TYPE (ubound), ubound, lbound);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
+ tmp, build_one_cst (TREE_TYPE (tmp)));
extent = fold_build2_loc (input_location, MULT_EXPR,
- integer_type_node, extent, tmp);
+ TREE_TYPE (tmp), extent, tmp);
}
}
- img_idx = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
- img_idx, integer_one_node);
- return img_idx;
+ img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (img_idx),
+ img_idx, build_one_cst (TREE_TYPE (img_idx)));
+ return fold_convert (integer_type_node, img_idx);
}
if (!cl->length)
{
gfc_expr* expr_flat;
- gcc_assert (expr);
+ if (!expr)
+ return;
expr_flat = gfc_copy_expr (expr);
flatten_array_ctors_without_strlen (expr_flat);
gfc_resolve_expr (expr_flat);
start.expr = gfc_evaluate_now (start.expr, &se->pre);
/* Change the start of the string. */
- if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
+ if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
+ || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
+ && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
tmp = se->expr;
else
tmp = build_fold_indirect_ref_loc (input_location,
conv_parent_component_references (se, &parent);
}
+
+static void
+conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts)
+{
+ tree res = se->expr;
+
+ switch (ref->u.i)
+ {
+ case INQUIRY_RE:
+ res = fold_build1_loc (input_location, REALPART_EXPR,
+ TREE_TYPE (TREE_TYPE (res)), res);
+ break;
+
+ case INQUIRY_IM:
+ res = fold_build1_loc (input_location, IMAGPART_EXPR,
+ TREE_TYPE (TREE_TYPE (res)), res);
+ break;
+
+ case INQUIRY_KIND:
+ res = build_int_cst (gfc_typenode_for_spec (&expr->ts),
+ ts->kind);
+ break;
+
+ case INQUIRY_LEN:
+ res = fold_convert (gfc_typenode_for_spec (&expr->ts),
+ se->string_length);
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+ se->expr = res;
+}
+
/* Return the contents of a variable. Also handles reference/pointer
variables (all Fortran pointer references are implicit). */
gcc_assert (se->string_length);
}
+ gfc_typespec *ts = &sym->ts;
while (ref)
{
switch (ref->type)
break;
case REF_COMPONENT:
+ ts = &ref->u.c.component->ts;
if (first_time && is_classarray && sym->attr.dummy
&& se->descriptor_only
&& !CLASS_DATA (sym)->attr.allocatable
expr->symtree->name, &expr->where);
break;
+ case REF_INQUIRY:
+ conv_inquiry (se, ref, expr, ts);
+ break;
+
default:
gcc_unreachable ();
break;
if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
return;
+ if (INTEGER_CST_P (lse.expr)
+ && TREE_CODE (TREE_TYPE (rse.expr)) == INTEGER_TYPE)
+ {
+ wi::tree_to_wide_ref wlhs = wi::to_wide (lse.expr);
+ HOST_WIDE_INT v, w;
+ int kind, ikind, bit_size;
+
+ v = wlhs.to_shwi ();
+ w = abs (v);
+
+ kind = expr->value.op.op1->ts.kind;
+ ikind = gfc_validate_kind (BT_INTEGER, kind, false);
+ bit_size = gfc_integer_kinds[ikind].bit_size;
+
+ if (v == 1)
+ {
+ /* 1**something is always 1. */
+ se->expr = build_int_cst (TREE_TYPE (lse.expr), 1);
+ return;
+ }
+ else if (v == -1)
+ {
+ /* (-1)**n is 1 - ((n & 1) << 1) */
+ tree type;
+ tree tmp;
+
+ type = TREE_TYPE (lse.expr);
+ tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type,
+ rse.expr, build_int_cst (type, 1));
+ tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
+ tmp, build_int_cst (type, 1));
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
+ build_int_cst (type, 1), tmp);
+ se->expr = tmp;
+ return;
+ }
+ else if (w > 0 && ((w & (w-1)) == 0) && ((w >> (bit_size-1)) == 0))
+ {
+ /* Here v is +/- 2**e. The further simplification uses
+ 2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
+ 1<<(4*n), etc., but we have to make sure to return zero
+ if the number of bits is too large. */
+ tree lshift;
+ tree type;
+ tree shift;
+ tree ge;
+ tree cond;
+ tree num_bits;
+ tree cond2;
+ tree tmp1;
+
+ type = TREE_TYPE (lse.expr);
+
+ if (w == 2)
+ shift = rse.expr;
+ else if (w == 4)
+ shift = fold_build2_loc (input_location, PLUS_EXPR,
+ TREE_TYPE (rse.expr),
+ rse.expr, rse.expr);
+ else
+ {
+ /* use popcount for fast log2(w) */
+ int e = wi::popcount (w-1);
+ shift = fold_build2_loc (input_location, MULT_EXPR,
+ TREE_TYPE (rse.expr),
+ build_int_cst (TREE_TYPE (rse.expr), e),
+ rse.expr);
+ }
+
+ lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
+ build_int_cst (type, 1), shift);
+ ge = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
+ rse.expr, build_int_cst (type, 0));
+ cond = fold_build3_loc (input_location, COND_EXPR, type, ge, lshift,
+ build_int_cst (type, 0));
+ num_bits = build_int_cst (TREE_TYPE (rse.expr), TYPE_PRECISION (type));
+ cond2 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
+ rse.expr, num_bits);
+ tmp1 = fold_build3_loc (input_location, COND_EXPR, type, cond2,
+ build_int_cst (type, 0), cond);
+ if (v > 0)
+ {
+ se->expr = tmp1;
+ }
+ else
+ {
+ /* for v < 0, calculate v**n = |v|**n * (-1)**n */
+ tree tmp2;
+ tmp2 = fold_build2_loc (input_location, BIT_AND_EXPR, type,
+ rse.expr, build_int_cst (type, 1));
+ tmp2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
+ tmp2, build_int_cst (type, 1));
+ tmp2 = fold_build2_loc (input_location, MINUS_EXPR, type,
+ build_int_cst (type, 1), tmp2);
+ se->expr = fold_build2_loc (input_location, MULT_EXPR, type,
+ tmp1, tmp2);
+ }
+ return;
+ }
+ }
+
gfc_int4_type_node = gfc_get_int_type (4);
/* In case of integer operands with kinds 1 or 2, we call the integer kind 4
static void
-conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
+conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr,
+ gfc_actual_arglist *actual_args)
{
tree tmp;
else
{
if (!sym->backend_decl)
- sym->backend_decl = gfc_get_extern_function_decl (sym);
+ sym->backend_decl = gfc_get_extern_function_decl (sym, actual_args);
TREE_USED (sym->backend_decl) = 1;
break;
case REF_COMPONENT:
+ case REF_INQUIRY:
break;
case REF_SUBSTRING:
case EXPR_COMPCALL:
case EXPR_PPC:
+ case EXPR_UNKNOWN:
gcc_unreachable ();
break;
}
an actual argument derived type array is copied and then returned
after the function call. */
void
-gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
- sym_intent intent, bool formal_ptr)
+gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
+ sym_intent intent, bool formal_ptr,
+ const gfc_symbol *fsym, const char *proc_name,
+ gfc_symbol *sym, bool check_contiguous)
{
gfc_se lse;
gfc_se rse;
stmtblock_t body;
int n;
int dimen;
+ gfc_se work_se;
+ gfc_se *parmse;
+ bool pass_optional;
+
+ pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
+
+ if (pass_optional || check_contiguous)
+ {
+ gfc_init_se (&work_se, NULL);
+ parmse = &work_se;
+ }
+ else
+ parmse = se;
+
+ if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
+ {
+ /* We will create a temporary array, so let us warn. */
+ char * msg;
+
+ if (fsym && proc_name)
+ msg = xasprintf ("An array temporary was created for argument "
+ "'%s' of procedure '%s'", fsym->name, proc_name);
+ else
+ msg = xasprintf ("An array temporary was created");
+
+ tmp = build_int_cst (logical_type_node, 1);
+ gfc_trans_runtime_check (false, true, tmp, &parmse->pre,
+ &expr->where, msg);
+ free (msg);
+ }
gfc_init_se (&lse, NULL);
gfc_init_se (&rse, NULL);
else
parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
+ /* Basically make this into
+
+ if (present)
+ {
+ if (contiguous)
+ {
+ pointer = a;
+ }
+ else
+ {
+ parmse->pre();
+ pointer = parmse->expr;
+ }
+ }
+ else
+ pointer = NULL;
+
+ foo (pointer);
+ if (present && !contiguous)
+ se->post();
+
+ */
+
+ if (pass_optional || check_contiguous)
+ {
+ tree type;
+ stmtblock_t else_block;
+ tree pre_stmts, post_stmts;
+ tree pointer;
+ tree else_stmt;
+ tree present_var = NULL_TREE;
+ tree cont_var = NULL_TREE;
+ tree post_cond;
+
+ type = TREE_TYPE (parmse->expr);
+ pointer = gfc_create_var (type, "arg_ptr");
+
+ if (check_contiguous)
+ {
+ gfc_se cont_se, array_se;
+ stmtblock_t if_block, else_block;
+ tree if_stmt, else_stmt;
+ mpz_t size;
+ bool size_set;
+
+ cont_var = gfc_create_var (boolean_type_node, "contiguous");
+
+ /* If the size is known to be one at compile-time, set
+ cont_var to true unconditionally. This may look
+ inelegant, but we're only doing this during
+ optimization, so the statements will be optimized away,
+ and this saves complexity here. */
+
+ size_set = gfc_array_size (expr, &size);
+ if (size_set && mpz_cmp_ui (size, 1) == 0)
+ {
+ gfc_add_modify (&se->pre, cont_var,
+ build_one_cst (boolean_type_node));
+ }
+ else
+ {
+ /* cont_var = is_contiguous (expr); . */
+ gfc_init_se (&cont_se, parmse);
+ gfc_conv_is_contiguous_expr (&cont_se, expr);
+ gfc_add_block_to_block (&se->pre, &(&cont_se)->pre);
+ gfc_add_modify (&se->pre, cont_var, cont_se.expr);
+ gfc_add_block_to_block (&se->pre, &(&cont_se)->post);
+ }
+
+ if (size_set)
+ mpz_clear (size);
+
+ /* arrayse->expr = descriptor of a. */
+ gfc_init_se (&array_se, se);
+ gfc_conv_expr_descriptor (&array_se, expr);
+ gfc_add_block_to_block (&se->pre, &(&array_se)->pre);
+ gfc_add_block_to_block (&se->pre, &(&array_se)->post);
+
+ /* if_stmt = { pointer = &a[0]; } . */
+ gfc_init_block (&if_block);
+ tmp = gfc_conv_array_data (array_se.expr);
+ tmp = fold_convert (type, tmp);
+ gfc_add_modify (&if_block, pointer, tmp);
+ if_stmt = gfc_finish_block (&if_block);
+
+ /* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */
+ gfc_init_block (&else_block);
+ gfc_add_block_to_block (&else_block, &parmse->pre);
+ gfc_add_modify (&else_block, pointer, parmse->expr);
+ else_stmt = gfc_finish_block (&else_block);
+
+ /* And put the above into an if statement. */
+ pre_stmts = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ gfc_likely (cont_var,
+ PRED_FORTRAN_CONTIGUOUS),
+ if_stmt, else_stmt);
+ }
+ else
+ {
+ /* pointer = pramse->expr; . */
+ gfc_add_modify (&parmse->pre, pointer, parmse->expr);
+ pre_stmts = gfc_finish_block (&parmse->pre);
+ }
+
+ if (pass_optional)
+ {
+ present_var = gfc_create_var (boolean_type_node, "present");
+
+ /* present_var = present(sym); . */
+ tmp = gfc_conv_expr_present (sym);
+ tmp = fold_convert (boolean_type_node, tmp);
+ gfc_add_modify (&se->pre, present_var, tmp);
+
+ /* else_stmt = { pointer = NULL; } . */
+ gfc_init_block (&else_block);
+ gfc_add_modify (&else_block, pointer, build_int_cst (type, 0));
+ else_stmt = gfc_finish_block (&else_block);
+
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ gfc_likely (present_var,
+ PRED_FORTRAN_ABSENT_DUMMY),
+ pre_stmts, else_stmt);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
+ else
+ gfc_add_expr_to_block (&se->pre, pre_stmts);
+
+ post_stmts = gfc_finish_block (&parmse->post);
+
+ /* Put together the post stuff, plus the optional
+ deallocation. */
+ if (check_contiguous)
+ {
+ /* !cont_var. */
+ tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ cont_var,
+ build_zero_cst (boolean_type_node));
+ tmp = gfc_unlikely (tmp, PRED_FORTRAN_CONTIGUOUS);
+
+ if (pass_optional)
+ {
+ tree present_likely = gfc_likely (present_var,
+ PRED_FORTRAN_ABSENT_DUMMY);
+ post_cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+ boolean_type_node, present_likely,
+ tmp);
+ }
+ else
+ post_cond = tmp;
+ }
+ else
+ {
+ gcc_assert (pass_optional);
+ post_cond = present_var;
+ }
+
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, post_cond,
+ post_stmts, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&se->post, tmp);
+ se->expr = pointer;
+ }
+
return;
}
indirectly for %LOC, else by reference. Thus %REF
is a "do-nothing" and %LOC is the same as an F95
pointer. */
- if (strncmp (name, "%VAL", 4) == 0)
+ if (strcmp (name, "%VAL") == 0)
gfc_conv_expr (se, expr);
- else if (strncmp (name, "%LOC", 4) == 0)
+ else if (strcmp (name, "%LOC") == 0)
{
gfc_conv_expr_reference (se, expr);
se->expr = gfc_build_addr_expr (NULL, se->expr);
}
- else if (strncmp (name, "%REF", 4) == 0)
+ else if (strcmp (name, "%REF") == 0)
gfc_conv_expr_reference (se, expr);
else
gfc_error ("Unknown argument list function at %L", &expr->where);
}
+/* A helper function to set the dtype for unallocated or unassociated
+ entities. */
+
+static void
+set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
+{
+ tree tmp;
+ tree desc;
+ tree cond;
+ tree type;
+ stmtblock_t block;
+
+ /* TODO Figure out how to handle optional dummies. */
+ if (e && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional)
+ return;
+
+ desc = parmse->expr;
+ if (desc == NULL_TREE)
+ return;
+
+ if (POINTER_TYPE_P (TREE_TYPE (desc)))
+ desc = build_fold_indirect_ref_loc (input_location, desc);
+
+ if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+ return;
+
+ gfc_init_block (&block);
+ tmp = gfc_conv_descriptor_data_get (desc);
+ cond = fold_build2_loc (input_location, EQ_EXPR,
+ logical_type_node, tmp,
+ build_int_cst (TREE_TYPE (tmp), 0));
+ tmp = gfc_conv_descriptor_dtype (desc);
+ type = gfc_get_element_type (TREE_TYPE (desc));
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ TREE_TYPE (tmp), tmp,
+ gfc_get_dtype_rank_type (e->rank, type));
+ gfc_add_expr_to_block (&block, tmp);
+ cond = build3_v (COND_EXPR, cond,
+ gfc_finish_block (&block),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&parmse->pre, cond);
+}
+
+
+
+/* Provide an interface between gfortran array descriptors and the F2018:18.4
+ ISO_Fortran_binding array descriptors. */
+
+static void
+gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
+{
+ tree tmp;
+ tree cfi_desc_ptr;
+ tree gfc_desc_ptr;
+ tree type;
+ tree cond;
+ tree desc_attr;
+ int attribute;
+ int cfi_attribute;
+ symbol_attribute attr = gfc_expr_attr (e);
+
+ /* If this is a full array or a scalar, the allocatable and pointer
+ attributes can be passed. Otherwise it is 'CFI_attribute_other'*/
+ attribute = 2;
+ if (!e->rank || gfc_get_full_arrayspec_from_expr (e))
+ {
+ if (attr.pointer)
+ attribute = 0;
+ else if (attr.allocatable)
+ attribute = 1;
+ }
+
+ /* If the formal argument is assumed shape and neither a pointer nor
+ allocatable, it is unconditionally CFI_attribute_other. */
+ if (fsym->as->type == AS_ASSUMED_SHAPE
+ && !fsym->attr.pointer && !fsym->attr.allocatable)
+ cfi_attribute = 2;
+ else
+ cfi_attribute = attribute;
+
+ if (e->rank != 0)
+ {
+ parmse->force_no_tmp = 1;
+ if (fsym->attr.contiguous
+ && !gfc_is_simply_contiguous (e, false, true))
+ gfc_conv_subref_array_arg (parmse, e, false, fsym->attr.intent,
+ fsym->attr.pointer);
+ else
+ gfc_conv_expr_descriptor (parmse, e);
+
+ if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
+ parmse->expr = build_fold_indirect_ref_loc (input_location,
+ parmse->expr);
+ bool is_artificial = (INDIRECT_REF_P (parmse->expr)
+ ? DECL_ARTIFICIAL (TREE_OPERAND (parmse->expr, 0))
+ : DECL_ARTIFICIAL (parmse->expr));
+
+ /* Unallocated allocatable arrays and unassociated pointer arrays
+ need their dtype setting if they are argument associated with
+ assumed rank dummies. */
+ if (fsym && fsym->as
+ && (gfc_expr_attr (e).pointer
+ || gfc_expr_attr (e).allocatable))
+ set_dtype_for_unallocated (parmse, e);
+
+ /* All the temporary descriptors are marked as DECL_ARTIFICIAL. If
+ the expression type is different from the descriptor type, then
+ the offset must be found (eg. to a component ref or substring)
+ and the dtype updated. Assumed type entities are only allowed
+ to be dummies in Fortran. They therefore lack the decl specific
+ appendiges and so must be treated differently from other fortran
+ entities passed to CFI descriptors in the interface decl. */
+ type = e->ts.type != BT_ASSUMED ? gfc_typenode_for_spec (&e->ts) :
+ NULL_TREE;
+
+ if (type && is_artificial
+ && type != gfc_get_element_type (TREE_TYPE (parmse->expr)))
+ {
+ /* Obtain the offset to the data. */
+ gfc_get_dataptr_offset (&parmse->pre, parmse->expr, parmse->expr,
+ gfc_index_zero_node, true, e);
+
+ /* Update the dtype. */
+ gfc_add_modify (&parmse->pre,
+ gfc_conv_descriptor_dtype (parmse->expr),
+ gfc_get_dtype_rank_type (e->rank, type));
+ }
+ else if (type == NULL_TREE
+ || (!is_subref_array (e) && !is_artificial))
+ {
+ /* Make sure that the span is set for expressions where it
+ might not have been done already. */
+ tmp = gfc_conv_descriptor_elem_len (parmse->expr);
+ tmp = fold_convert (gfc_array_index_type, tmp);
+ gfc_conv_descriptor_span_set (&parmse->pre, parmse->expr, tmp);
+ }
+ }
+ else
+ {
+ gfc_conv_expr (parmse, e);
+
+ if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
+ parmse->expr = build_fold_indirect_ref_loc (input_location,
+ parmse->expr);
+
+ parmse->expr = gfc_conv_scalar_to_descriptor (parmse,
+ parmse->expr, attr);
+ }
+
+ /* Set the CFI attribute field through a temporary value for the
+ gfc attribute. */
+ desc_attr = gfc_conv_descriptor_attribute (parmse->expr);
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ void_type_node, desc_attr,
+ build_int_cst (TREE_TYPE (desc_attr), cfi_attribute));
+ gfc_add_expr_to_block (&parmse->pre, tmp);
+
+ /* Now pass the gfc_descriptor by reference. */
+ parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
+
+ /* Variables to point to the gfc and CFI descriptors; cfi = NULL implies
+ that the CFI descriptor is allocated by the gfor_fndecl_gfc_to_cfi call. */
+ gfc_desc_ptr = parmse->expr;
+ cfi_desc_ptr = gfc_create_var (pvoid_type_node, "cfi");
+ gfc_add_modify (&parmse->pre, cfi_desc_ptr, null_pointer_node);
+
+ /* Allocate the CFI descriptor itself and fill the fields. */
+ tmp = gfc_build_addr_expr (NULL_TREE, cfi_desc_ptr);
+ tmp = build_call_expr_loc (input_location,
+ gfor_fndecl_gfc_to_cfi, 2, tmp, gfc_desc_ptr);
+ gfc_add_expr_to_block (&parmse->pre, tmp);
+
+ /* Now set the gfc descriptor attribute. */
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ void_type_node, desc_attr,
+ build_int_cst (TREE_TYPE (desc_attr), attribute));
+ gfc_add_expr_to_block (&parmse->pre, tmp);
+
+ /* The CFI descriptor is passed to the bind_C procedure. */
+ parmse->expr = cfi_desc_ptr;
+
+ /* Free the CFI descriptor. */
+ tmp = gfc_call_free (cfi_desc_ptr);
+ gfc_prepend_expr_to_block (&parmse->post, tmp);
+
+ /* Transfer values back to gfc descriptor. */
+ tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr);
+ tmp = build_call_expr_loc (input_location,
+ gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp);
+ gfc_prepend_expr_to_block (&parmse->post, tmp);
+
+ /* Deal with an optional dummy being passed to an optional formal arg
+ by finishing the pre and post blocks and making their execution
+ conditional on the dummy being present. */
+ if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional)
+ {
+ cond = gfc_conv_expr_present (e->symtree->n.sym);
+ tmp = fold_build2 (MODIFY_EXPR, void_type_node,
+ cfi_desc_ptr,
+ build_int_cst (pvoid_type_node, 0));
+ tmp = build3_v (COND_EXPR, cond,
+ gfc_finish_block (&parmse->pre), tmp);
+ gfc_add_expr_to_block (&parmse->pre, tmp);
+ tmp = build3_v (COND_EXPR, cond,
+ gfc_finish_block (&parmse->post),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&parmse->post, tmp);
+ }
+}
+
+
/* Generate code for a procedure call. Note can return se->post != NULL.
If se->direct_byref is set then se->expr contains the return parameter.
Return nonzero, if the call has alternate specifiers.
for (arg = args, argc = 0; arg != NULL;
arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
{
+ bool finalized = false;
+ bool non_unity_length_string = false;
+
e = arg->expr;
fsym = formal ? formal->sym : NULL;
parm_kind = MISSING;
+ if (fsym && fsym->ts.type == BT_CHARACTER && fsym->ts.u.cl
+ && (!fsym->ts.u.cl->length
+ || fsym->ts.u.cl->length->expr_type != EXPR_CONSTANT
+ || mpz_cmp_si (fsym->ts.u.cl->length->value.integer, 1) != 0))
+ non_unity_length_string = true;
+
/* If the procedure requires an explicit interface, the actual
argument is passed according to the corresponding formal
argument. If the corresponding formal argument is a POINTER,
tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
parmse.expr = convert (type, tmp);
}
- else if (fsym && fsym->attr.value)
+
+ else if (sym->attr.is_bind_c && e
+ && (is_CFI_desc (fsym, NULL)
+ || non_unity_length_string))
+ /* Implement F2018, C.12.6.1: paragraph (2). */
+ gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
+
+ else if (fsym && fsym->attr.value)
{
if (fsym->ts.type == BT_CHARACTER
&& fsym->ts.is_c_interop
}
}
}
+
else if (arg->name && arg->name[0] == '%')
/* Argument list functions %VAL, %LOC and %REF are signalled
through arg->name. */
gfc_conv_expr (&parmse, e);
parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
}
+
else if (e->expr_type == EXPR_FUNCTION
&& e->symtree->n.sym->result
&& e->symtree->n.sym->result != e->symtree->n.sym
if (fsym && fsym->attr.proc_pointer)
parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
}
+
else
{
if (e->ts.type == BT_CLASS && fsym
}
}
else
- gfc_conv_expr_reference (&parmse, e);
-
+ {
+ bool add_clobber;
+ add_clobber = fsym && fsym->attr.intent == INTENT_OUT
+ && !fsym->attr.allocatable && !fsym->attr.pointer
+ && !e->symtree->n.sym->attr.dimension
+ && !e->symtree->n.sym->attr.pointer
+ /* See PR 41453. */
+ && !e->symtree->n.sym->attr.dummy
+ /* FIXME - PR 87395 and PR 41453 */
+ && e->symtree->n.sym->attr.save == SAVE_NONE
+ && !e->symtree->n.sym->attr.associate_var
+ && e->ts.type != BT_CHARACTER && e->ts.type != BT_DERIVED
+ && e->ts.type != BT_CLASS && !sym->attr.elemental;
+
+ gfc_conv_expr_reference (&parmse, e, add_clobber);
+ }
/* Catch base objects that are not variables. */
if (e->ts.type == BT_CLASS
&& e->expr_type != EXPR_VARIABLE
&& e->ts.type == BT_CLASS
&& !CLASS_DATA (e)->attr.dimension
&& !CLASS_DATA (e)->attr.codimension)
- parmse.expr = gfc_class_data_get (parmse.expr);
+ {
+ parmse.expr = gfc_class_data_get (parmse.expr);
+ /* The result is a class temporary, whose _data component
+ must be freed to avoid a memory leak. */
+ if (e->expr_type == EXPR_FUNCTION
+ && CLASS_DATA (e)->attr.allocatable)
+ {
+ tree zero;
+
+ gfc_expr *var;
+
+ /* Borrow the function symbol to make a call to
+ gfc_add_finalizer_call and then restore it. */
+ tmp = e->symtree->n.sym->backend_decl;
+ e->symtree->n.sym->backend_decl
+ = TREE_OPERAND (parmse.expr, 0);
+ e->symtree->n.sym->attr.flavor = FL_VARIABLE;
+ var = gfc_lval_expr_from_sym (e->symtree->n.sym);
+ finalized = gfc_add_finalizer_call (&parmse.post,
+ var);
+ gfc_free_expr (var);
+ e->symtree->n.sym->backend_decl = tmp;
+ e->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+
+ /* Then free the class _data. */
+ zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
+ tmp = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node,
+ parmse.expr, zero);
+ tmp = build3_v (COND_EXPR, tmp,
+ gfc_call_free (parmse.expr),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&parmse.post, tmp);
+ gfc_add_modify (&parmse.post, parmse.expr, zero);
+ }
+ }
/* Wrap scalar variable in a descriptor. We need to convert
the address of a pointer back to the pointer itself before,
parmse.force_tmp = 1;
}
- if (e->expr_type == EXPR_VARIABLE
+ if (sym->attr.is_bind_c && e
+ && (is_CFI_desc (fsym, NULL) || non_unity_length_string))
+ /* Implement F2018, C.12.6.1: paragraph (2). */
+ gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
+
+ else if (e->expr_type == EXPR_VARIABLE
&& is_subref_array (e)
&& !(fsym && fsym->attr.pointer))
/* The actual argument is a component reference to an
gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
fsym ? fsym->attr.intent : INTENT_INOUT,
fsym && fsym->attr.pointer);
+
else if (gfc_is_class_array_ref (e, NULL)
&& fsym && fsym->ts.type == BT_DERIVED)
/* The actual argument is a component reference to an
INTENT_IN,
fsym && fsym->attr.pointer);
}
+ else if (fsym && fsym->attr.contiguous
+ && !gfc_is_simply_contiguous (e, false, true))
+ {
+ gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
+ fsym ? fsym->attr.intent : INTENT_INOUT,
+ fsym && fsym->attr.pointer);
+ }
else
gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
sym->name, NULL);
+ /* Unallocated allocatable arrays and unassociated pointer arrays
+ need their dtype setting if they are argument associated with
+ assumed rank dummies. */
+ if (!sym->attr.is_bind_c && e && fsym && fsym->as
+ && fsym->as->type == AS_ASSUMED_RANK)
+ {
+ if (gfc_expr_attr (e).pointer
+ || gfc_expr_attr (e).allocatable)
+ set_dtype_for_unallocated (&parmse, e);
+ else if (e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.dummy
+ && e->symtree->n.sym->as
+ && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
+ {
+ tree minus_one;
+ tmp = build_fold_indirect_ref_loc (input_location,
+ parmse.expr);
+ minus_one = build_int_cst (gfc_array_index_type, -1);
+ gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
+ gfc_rank_cst[e->rank - 1],
+ minus_one);
+ }
+ }
+
/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
allocated on entry, it must be deallocated. */
if (fsym && fsym->attr.allocatable
gfc_add_expr_to_block (&se->pre, tmp);
}
- tmp = build_fold_indirect_ref_loc (input_location,
- parmse.expr);
+ tmp = parmse.expr;
+ /* With bind(C), the actual argument is replaced by a bind-C
+ descriptor; in this case, the data component arrives here,
+ which shall not be dereferenced, but still freed and
+ nullified. */
+ if (TREE_TYPE(tmp) != pvoid_type_node)
+ tmp = build_fold_indirect_ref_loc (input_location,
+ parmse.expr);
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,
array-descriptor actual to array-descriptor dummy, see
PR 41911 for why a check has to be inserted.
fsym == NULL is checked as intrinsics required the descriptor
- but do not always set fsym. */
+ but do not always set fsym.
+ Also, it is necessary to pass a NULL pointer to library routines
+ which usually ignore optional arguments, so they can handle
+ these themselves. */
if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.optional
- && ((e->rank != 0 && elemental_proc)
- || e->representation.length || e->ts.type == BT_CHARACTER
- || (e->rank != 0
- && (fsym == NULL
- || (fsym-> as
- && (fsym->as->type == AS_ASSUMED_SHAPE
- || fsym->as->type == AS_ASSUMED_RANK
- || fsym->as->type == AS_DEFERRED))))))
+ && (((e->rank != 0 && elemental_proc)
+ || e->representation.length || e->ts.type == BT_CHARACTER
+ || (e->rank != 0
+ && (fsym == NULL
+ || (fsym->as
+ && (fsym->as->type == AS_ASSUMED_SHAPE
+ || fsym->as->type == AS_ASSUMED_RANK
+ || fsym->as->type == AS_DEFERRED)))))
+ || se->ignore_optional))
gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
e->representation.length);
}
break;
}
+ if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
+ {
+ /* The derived type is passed to gfc_deallocate_alloc_comp.
+ Therefore, class actuals can be handled correctly but derived
+ types passed to class formals need the _data component. */
+ tmp = gfc_class_data_get (tmp);
+ if (!CLASS_DATA (fsym)->attr.dimension)
+ tmp = build_fold_indirect_ref_loc (input_location, tmp);
+ }
+
if (e->expr_type == EXPR_OP
&& e->value.op.op == INTRINSIC_PARENTHESES
&& e->value.op.op1->expr_type == EXPR_VARIABLE)
gfc_add_expr_to_block (&se->post, local_tmp);
}
- if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
+ if (!finalized && !e->must_finalize)
{
- /* The derived type is passed to gfc_deallocate_alloc_comp.
- Therefore, class actuals can handled correctly but derived
- types passed to class formals need the _data component. */
- tmp = gfc_class_data_get (tmp);
- if (!CLASS_DATA (fsym)->attr.dimension)
- tmp = build_fold_indirect_ref_loc (input_location, tmp);
+ if ((e->ts.type == BT_CLASS
+ && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
+ || e->ts.type == BT_DERIVED)
+ tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
+ parm_rank);
+ else if (e->ts.type == BT_CLASS)
+ tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
+ tmp, parm_rank);
+ gfc_prepend_expr_to_block (&post, tmp);
}
-
- tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
-
- gfc_prepend_expr_to_block (&post, tmp);
}
/* Add argument checking of passing an unallocated/NULL actual to
/* When calling __copy for character expressions to unlimited
polymorphic entities, the dst argument needs a string length. */
if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
- && strncmp (sym->name, "__vtab_CHARACTER", 16) == 0
+ && gfc_str_startswith (sym->name, "__vtab_CHARACTER")
&& arg->next && arg->next->expr
&& (arg->next->expr->ts.type == BT_DERIVED
|| arg->next->expr->ts.type == BT_CLASS)
/* Generate the actual call. */
if (base_object == NULL_TREE)
- conv_function_val (se, sym, expr);
+ conv_function_val (se, sym, expr, args);
else
conv_base_obj_fcn_val (se, base_object, expr);
gfc_allocate_lang_decl (result);
GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
gfc_free_expr (class_expr);
- gcc_assert (parmse.pre.head == NULL_TREE
- && parmse.post.head == NULL_TREE);
+ /* -fcheck= can add diagnostic code, which has to be placed before
+ the call. */
+ if (parmse.pre.head != NULL)
+ gfc_add_expr_to_block (&se->pre, parmse.pre.head);
+ gcc_assert (parmse.post.head == NULL_TREE);
}
/* Follow the function call with the argument post block. */
final_fndecl = gfc_class_vtab_final_get (se->expr);
is_final = fold_build2_loc (input_location, NE_EXPR,
logical_type_node,
- final_fndecl,
+ final_fndecl,
fold_convert (TREE_TYPE (final_fndecl),
null_pointer_node));
final_fndecl = build_fold_indirect_ref_loc (input_location,
gfc_build_addr_expr (NULL, tmp),
gfc_class_vtab_size_get (se->expr),
boolean_false_node);
- tmp = fold_build3_loc (input_location, COND_EXPR,
+ tmp = fold_build3_loc (input_location, COND_EXPR,
void_type_node, is_final, tmp,
build_empty_stmt (input_location));
if (se->ss && se->ss->loop)
{
- gfc_add_expr_to_block (&se->ss->loop->post, tmp);
- tmp = gfc_call_free (info->data);
+ gfc_prepend_expr_to_block (&se->ss->loop->post, tmp);
+ tmp = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node,
+ info->data,
+ fold_convert (TREE_TYPE (info->data),
+ null_pointer_node));
+ tmp = fold_build3_loc (input_location, COND_EXPR,
+ void_type_node, tmp,
+ gfc_call_free (info->data),
+ build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->ss->loop->post, tmp);
}
else
{
- gfc_add_expr_to_block (&se->post, tmp);
- tmp = gfc_class_data_get (se->expr);
- tmp = gfc_call_free (tmp);
+ tree classdata;
+ gfc_prepend_expr_to_block (&se->post, tmp);
+ classdata = gfc_class_data_get (se->expr);
+ tmp = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node,
+ classdata,
+ fold_convert (TREE_TYPE (classdata),
+ null_pointer_node));
+ tmp = fold_build3_loc (input_location, COND_EXPR,
+ void_type_node, tmp,
+ gfc_call_free (classdata),
+ build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->post, tmp);
}
-
-no_finalization:
- expr->must_finalize = 0;
}
+no_finalization:
gfc_add_block_to_block (&se->post, &post);
}
if (expr != NULL && expr->ts.type == BT_DERIVED
&& expr->ts.is_iso_c && expr->ts.u.derived)
{
- gfc_symbol *derived = expr->ts.u.derived;
-
- /* The derived symbol has already been converted to a (void *). Use
- its kind. */
- if (derived->ts.kind == 0)
- derived->ts.kind = gfc_default_integer_kind;
- expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
- expr->ts.f90_type = derived->ts.f90_type;
-
- gfc_init_se (&se, NULL);
- gfc_conv_constant (&se, expr);
- gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
- return se.expr;
+ if (TREE_CODE (type) == ARRAY_TYPE)
+ return build_constructor (type, NULL);
+ else if (POINTER_TYPE_P (type))
+ return build_int_cst (type, 0);
+ else
+ gcc_unreachable ();
}
if (array && !procptr)
suffices to recognize the data as array. */
if (rank < 0)
rank = 1;
- size = integer_zero_node;
+ size = build_zero_cst (size_type_node);
desc = field;
gfc_add_modify (&block, gfc_conv_descriptor_rank (desc),
build_int_cst (signed_char_type_node, rank));
values only. */
void
-gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
+gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr, bool add_clobber)
{
gfc_ss *ss;
tree var;
gfc_add_block_to_block (&se->pre, &se->post);
se->expr = var;
}
+ else if (add_clobber && expr->ref == NULL)
+ {
+ tree clobber;
+ tree var;
+ /* FIXME: This fails if var is passed by reference, see PR
+ 41453. */
+ var = expr->symtree->n.sym->backend_decl;
+ clobber = build_clobber (TREE_TYPE (var));
+ gfc_add_modify (&se->pre, var, clobber);
+ }
return;
}
var = gfc_create_var (TREE_TYPE (se->expr), NULL);
gfc_add_modify (&se->pre, var, se->expr);
}
- gfc_add_block_to_block (&se->pre, &se->post);
+
+ if (!expr->must_finalize)
+ gfc_add_block_to_block (&se->pre, &se->post);
/* Take the address of that value. */
se->expr = gfc_build_addr_expr (NULL_TREE, var);
from_len = rse->string_length;
else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
{
- from_len = gfc_get_expr_charlen (re);
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, re->ts.u.cl->length);
gfc_add_block_to_block (block, &se.pre);
}
}
-/* Indentify class valued proc_pointer assignments. */
-
-static bool
-pointer_assignment_is_proc_pointer (gfc_expr * expr1, gfc_expr * expr2)
-{
- gfc_ref * ref;
-
- ref = expr1->ref;
- while (ref && ref->next)
- ref = ref->next;
-
- return ref && ref->type == REF_COMPONENT
- && ref->u.c.component->attr.proc_pointer
- && expr2->expr_type == EXPR_VARIABLE
- && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE;
-}
-
/* Do everything that is needed for a CLASS function expr2. */
tree desc;
tree tmp;
tree expr1_vptr = NULL_TREE;
- bool scalar, non_proc_pointer_assign;
+ bool scalar, non_proc_ptr_assign;
gfc_ss *ss;
gfc_start_block (&block);
gfc_init_se (&lse, NULL);
/* Usually testing whether this is not a proc pointer assignment. */
- non_proc_pointer_assign = !pointer_assignment_is_proc_pointer (expr1, expr2);
+ non_proc_ptr_assign = !(gfc_expr_attr (expr1).proc_pointer
+ && expr2->expr_type == EXPR_VARIABLE
+ && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE);
/* Check whether the expression is a scalar or not; we cannot use
expr1->rank as it can be nonzero for proc pointers. */
gfc_free_ss_chain (ss);
if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
- && expr2->expr_type != EXPR_FUNCTION && non_proc_pointer_assign)
+ && expr2->expr_type != EXPR_FUNCTION && non_proc_ptr_assign)
{
gfc_add_data_component (expr2);
/* The following is required as gfc_add_data_component doesn't
else
gfc_conv_expr (&rse, expr2);
- if (non_proc_pointer_assign && expr1->ts.type == BT_CLASS)
+ if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS)
{
trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
NULL);
}
}
- /* Check string lengths if applicable. The check is only really added
- to the output code if -fbounds-check is enabled. */
- if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
- {
- gcc_assert (expr2->ts.type == BT_CHARACTER);
- gcc_assert (strlen_lhs && strlen_rhs);
- gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
- strlen_lhs, strlen_rhs, &block);
- }
-
/* If rank remapping was done, check with -fcheck=bounds that
the target is at least as large as the pointer. */
if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
msg, rsize, lsize);
}
+ if (expr1->ts.type == BT_CHARACTER
+ && expr1->symtree->n.sym->ts.deferred
+ && expr1->symtree->n.sym->ts.u.cl->backend_decl
+ && VAR_P (expr1->symtree->n.sym->ts.u.cl->backend_decl))
+ {
+ tmp = expr1->symtree->n.sym->ts.u.cl->backend_decl;
+ if (expr2->expr_type != EXPR_NULL)
+ gfc_add_modify (&block, tmp,
+ fold_convert (TREE_TYPE (tmp), strlen_rhs));
+ else
+ gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
+ }
+
+ /* Check string lengths if applicable. The check is only really added
+ to the output code if -fbounds-check is enabled. */
+ if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
+ {
+ gcc_assert (expr2->ts.type == BT_CHARACTER);
+ gcc_assert (strlen_lhs && strlen_rhs);
+ gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
+ strlen_lhs, strlen_rhs, &block);
+ }
+
gfc_add_block_to_block (&block, &lse.post);
if (rank_remap)
gfc_add_block_to_block (&block, &rse.post);
return;
}
- if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
+ if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
+ || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
+ && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
{
if (TREE_CODE (se->expr) != INDIRECT_REF)
{
/* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
functions. */
comp = gfc_get_proc_ptr_comp (expr2);
- gcc_assert (expr2->value.function.isym
+
+ if (!(expr2->value.function.isym
|| (comp && comp->attr.dimension)
|| (!comp && gfc_return_by_reference (expr2->value.function.esym)
- && expr2->value.function.esym->result->attr.dimension));
+ && expr2->value.function.esym->result->attr.dimension)))
+ return NULL;
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
stype = gfc_typenode_for_spec (&expr2->ts);
src = gfc_build_constant_array_constructor (expr2, stype);
- stype = TREE_TYPE (src);
- if (POINTER_TYPE_P (stype))
- stype = TREE_TYPE (stype);
-
return gfc_build_memcpy_call (dst, src, len);
}
|| TREE_CODE (rse.string_length) == INDIRECT_REF))
string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
else if (expr2->ts.type == BT_CHARACTER)
- string_length = rse.string_length;
+ {
+ if (expr1->ts.deferred
+ && gfc_expr_attr (expr1).allocatable
+ && gfc_check_dependency (expr1, expr2, true))
+ rse.string_length =
+ gfc_evaluate_now_function_scope (rse.string_length, &rse.pre);
+ string_length = rse.string_length;
+ }
else
string_length = NULL_TREE;
/* When assigning a character function result to a deferred-length variable,
the function call must happen before the (re)allocation of the lhs -
otherwise the character length of the result is not known.
- NOTE: This relies on having the exact dependence of the length type
+ NOTE 1: This relies on having the exact dependence of the length type
parameter available to the caller; gfortran saves it in the .mod files.
- NOTE ALSO: The concatenation operation generates a temporary pointer,
+ NOTE 2: Vector array references generate an index temporary that must
+ not go outside the loop. Otherwise, variables should not generate
+ a pre block.
+ NOTE 3: The concatenation operation generates a temporary pointer,
whose allocation must go to the innermost loop.
- NOTE ALSO (2): A character conversion may generate a temporary, too. */
+ NOTE 4: Elemental functions may generate a temporary, too. */
if (flag_realloc_lhs
&& expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
&& !(lss != gfc_ss_terminator
- && ((expr2->expr_type == EXPR_OP
- && expr2->value.op.op == INTRINSIC_CONCAT)
+ && rss != gfc_ss_terminator
+ && ((expr2->expr_type == EXPR_VARIABLE && expr2->rank)
+ || (expr2->expr_type == EXPR_FUNCTION
+ && expr2->value.function.esym != NULL
+ && expr2->value.function.esym->attr.elemental)
|| (expr2->expr_type == EXPR_FUNCTION
&& expr2->value.function.isym != NULL
- && expr2->value.function.isym->id == GFC_ISYM_CONVERSION))))
+ && expr2->value.function.isym->elemental)
+ || (expr2->expr_type == EXPR_OP
+ && expr2->value.op.op == INTRINSIC_CONCAT))))
gfc_add_block_to_block (&block, &rse.pre);
/* Nullify the allocatable components corresponding to those of the lhs
&& (gfc_is_class_array_function (expr2)
|| gfc_is_alloc_class_scalar_function (expr2)))
{
- tmp = rse.expr;
tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
gfc_prepend_expr_to_block (&rse.post, tmp);
if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
gfc_add_block_to_block (&loop.post, &rse.post);
}
+ tmp = NULL_TREE;
+
if (is_poly_assign)
tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
use_vptr_copy || (lhs_attr.allocatable
code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
tmp = gfc_conv_intrinsic_subroutine (&code);
}
- else
+ else if (!is_poly_assign && expr2->must_finalize
+ && expr1->ts.type == BT_CLASS
+ && expr2->ts.type == BT_CLASS)
+ {
+ /* This case comes about when the scalarizer provides array element
+ references. Use the vptr copy function, since this does a deep
+ copy of allocatable components, without which the finalizer call */
+ tmp = gfc_get_vptr_from_expr (rse.expr);
+ if (tmp != NULL_TREE)
+ {
+ tree fcn = gfc_vptr_copy_get (tmp);
+ if (POINTER_TYPE_P (TREE_TYPE (fcn)))
+ fcn = build_fold_indirect_ref_loc (input_location, fcn);
+ tmp = build_call_expr_loc (input_location,
+ fcn, 2,
+ gfc_build_addr_expr (NULL, rse.expr),
+ gfc_build_addr_expr (NULL, lse.expr));
+ }
+ }
+
+ /* If nothing else works, do it the old fashioned way! */
+ if (tmp == NULL_TREE)
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
gfc_expr_is_variable (expr2)
|| scalar_to_array
|| expr2->expr_type == EXPR_ARRAY,
!(l_is_temp || init_flag) && dealloc,
expr1->symtree->n.sym->attr.codimension);
+
/* Add the pre blocks to the body. */
gfc_add_block_to_block (&body, &rse.pre);
gfc_add_block_to_block (&body, &lse.pre);
projects / platform / upstream / gcc.git / blobdiff