/* Expression translation
- Copyright (C) 2002-2017 Free Software Foundation, Inc.
+ Copyright (C) 2002-2020 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
tree
gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
{
- tree desc, type;
+ tree desc, type, etype;
type = get_scalar_to_descriptor_type (scalar, attr);
+ etype = TREE_TYPE (scalar);
desc = gfc_create_var (type, "desc");
DECL_ARTIFICIAL (desc) = 1;
}
if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
scalar = gfc_build_addr_expr (NULL_TREE, scalar);
+ else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE)
+ etype = TREE_TYPE (etype);
gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
- gfc_get_dtype (type));
+ gfc_get_dtype_rank_type (0, etype));
gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
/* Copy pointer address back - but only if it could have changed and
return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (len), decl, len,
NULL_TREE)
- : integer_zero_node;
+ : build_zero_cst (gfc_charlen_type_node);
}
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;
tree ctree;
tree var;
tree tmp;
+ int dim;
/* The derived type needs to be converted to a temporary
CLASS object. */
{
stmtblock_t block;
gfc_init_block (&block);
+ gfc_ref *ref;
parmse->ss = ss;
+ parmse->use_offset = 1;
gfc_conv_expr_descriptor (parmse, e);
+ /* Detect any array references with vector subscripts. */
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY
+ && ref->u.ar.type != AR_ELEMENT
+ && ref->u.ar.type != AR_FULL)
+ {
+ for (dim = 0; dim < ref->u.ar.dimen; dim++)
+ if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
+ break;
+ if (dim < ref->u.ar.dimen)
+ break;
+ }
+
+ /* Array references with vector subscripts and non-variable expressions
+ need be converted to a one-based descriptor. */
+ if (ref || e->expr_type != EXPR_VARIABLE)
+ {
+ for (dim = 0; dim < e->rank; ++dim)
+ gfc_conv_shift_descriptor_lbound (&block, parmse->expr, dim,
+ gfc_index_one_node);
+ }
+
if (e->rank != class_ts.u.derived->components->as->rank)
{
gcc_assert (class_ts.u.derived->components->as->type
tree ctree;
tree var;
tree tmp;
+ int dim;
/* The intrinsic type needs to be converted to a temporary
CLASS object. */
parmse->ss = ss;
parmse->use_offset = 1;
gfc_conv_expr_descriptor (parmse, e);
+
+ /* Array references with vector subscripts and non-variable expressions
+ need be converted to a one-based descriptor. */
+ if (e->expr_type != EXPR_VARIABLE)
+ {
+ for (dim = 0; dim < e->rank; ++dim)
+ gfc_conv_shift_descriptor_lbound (&parmse->pre, parmse->expr,
+ dim, gfc_index_one_node);
+ }
+
if (class_ts.u.derived->components->as->rank != e->rank)
{
tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
{
/* Amazingly all data is present to compute the length of a
constant string, but the expression is not yet there. */
- e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER, 4,
+ e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER,
+ gfc_charlen_int_kind,
&e->where);
mpz_set_ui (e->ts.u.cl->length->value.integer,
e->value.character.length);
}
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);
}
}
}
else
tmp = integer_zero_node;
- gfc_add_modify (&parmse->pre, ctree, tmp);
+ gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp));
}
else if (class_ts.type == BT_CLASS
&& class_ts.u.derived->components
}
if ((ref == NULL || class_ref == ref)
+ && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
&& (!class_ts.u.derived->components->as
|| class_ts.u.derived->components->as->rank != -1))
return;
First we have to find the corresponding class reference. */
tmp = NULL_TREE;
- if (class_ref == NULL
- && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
+ if (gfc_is_class_array_function (e)
+ && parmse->class_vptr != NULL_TREE)
+ tmp = parmse->class_vptr;
+ else if (class_ref == NULL
+ && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
{
tmp = e->symtree->n.sym->backend_decl;
if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
- slen = integer_zero_node;
+ slen = build_zero_cst (size_type_node);
}
else
{
if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
tmp = build_fold_indirect_ref_loc (input_location, tmp);
- vptr = gfc_class_vptr_get (tmp);
+ if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
+ vptr = gfc_class_vptr_get (tmp);
+ else
+ vptr = tmp;
+
gfc_add_modify (&block, ctree,
fold_convert (TREE_TYPE (ctree), vptr));
tmp = slen;
}
else
- tmp = integer_zero_node;
+ tmp = build_zero_cst (size_type_node);
gfc_add_modify (&parmse->pre, ctree,
fold_convert (TREE_TYPE (ctree), tmp));
/* 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));
}
of the referenced element. */
tree
-gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp)
+gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
+ bool unlimited)
{
- tree data = data_comp != NULL_TREE ? data_comp :
- gfc_class_data_get (class_decl);
- tree size = gfc_class_vtab_size_get (class_decl);
- tree offset = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type,
- index, size);
- tree ptr;
+ tree data, size, tmp, ctmp, offset, ptr;
+
+ data = data_comp != NULL_TREE ? data_comp :
+ gfc_class_data_get (class_decl);
+ size = gfc_class_vtab_size_get (class_decl);
+
+ if (unlimited)
+ {
+ tmp = fold_convert (gfc_array_index_type,
+ gfc_class_len_get (class_decl));
+ ctmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, size, tmp);
+ tmp = fold_build2_loc (input_location, GT_EXPR,
+ logical_type_node, tmp,
+ build_zero_cst (TREE_TYPE (tmp)));
+ size = fold_build3_loc (input_location, COND_EXPR,
+ gfc_array_index_type, tmp, ctmp, size);
+ }
+
+ offset = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type,
+ index, size);
+
data = gfc_conv_descriptor_data_get (data);
ptr = fold_convert (pvoid_type_node, data);
ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
if (from != NULL_TREE && unlimited)
from_len = gfc_class_len_or_zero_get (from);
else
- from_len = integer_zero_node;
+ from_len = build_zero_cst (size_type_node);
}
if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
if (is_from_desc)
{
- from_ref = gfc_get_class_array_ref (index, from, from_data);
+ from_ref = gfc_get_class_array_ref (index, from, from_data,
+ unlimited);
vec_safe_push (args, from_ref);
}
else
vec_safe_push (args, from_data);
if (is_to_class)
- to_ref = gfc_get_class_array_ref (index, to, to_data);
+ to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited);
else
{
tmp = gfc_conv_array_data (to);
from_len = gfc_conv_descriptor_size (from_data, 1);
tmp = fold_build2_loc (input_location, NE_EXPR,
- boolean_type_node, from_len, orig_nelems);
+ logical_type_node, from_len, orig_nelems);
msg = xasprintf ("Array bound mismatch for dimension %d "
"of array '%s' (%%ld/%%ld)",
1, name);
extcopy = gfc_finish_block (&ifbody);
tmp = fold_build2_loc (input_location, GT_EXPR,
- boolean_type_node, from_len,
- integer_zero_node);
+ logical_type_node, from_len,
+ build_zero_cst (TREE_TYPE (from_len)));
tmp = fold_build3_loc (input_location, COND_EXPR,
void_type_node, tmp, extcopy, stdcopy);
gfc_add_expr_to_block (&body, tmp);
vec_safe_push (args, to_len);
extcopy = build_call_vec (fcn_type, fcn, args);
tmp = fold_build2_loc (input_location, GT_EXPR,
- boolean_type_node, from_len,
- integer_zero_node);
+ logical_type_node, from_len,
+ build_zero_cst (TREE_TYPE (from_len)));
tmp = fold_build3_loc (input_location, COND_EXPR,
void_type_node, tmp, extcopy, stdcopy);
}
{
tree cond;
cond = fold_build2_loc (input_location, NE_EXPR,
- boolean_type_node,
+ logical_type_node,
from_data, null_pointer_node);
tmp = fold_build3_loc (input_location, COND_EXPR,
void_type_node, cond,
gfc_init_se (&src, NULL);
gfc_conv_expr (&src, rhs);
src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
- tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
src.expr, fold_convert (TREE_TYPE (src.expr),
null_pointer_node));
res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res,
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);
{
/* Check if _def_init is non-NULL. */
tree cond = fold_build2_loc (input_location, NE_EXPR,
- boolean_type_node, src.expr,
+ logical_type_node, src.expr,
fold_convert (TREE_TYPE (src.expr),
null_pointer_node));
tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
Care must be taken when multiple se are created with the same parent.
The child se must be kept in sync. The easiest way is to delay creation
- of a child se until after after the previous se has been translated. */
+ of a child se until after the previous se has been translated. */
void
gfc_init_se (gfc_se * se, gfc_se * parent)
Also used for arguments to procedures with multiple entry points. */
tree
-gfc_conv_expr_present (gfc_symbol * sym)
+gfc_conv_expr_present (gfc_symbol * sym, bool use_saved_desc)
{
- tree decl, cond;
+ tree decl, orig_decl, cond;
gcc_assert (sym->attr.dummy);
- decl = gfc_get_symbol_decl (sym);
+ orig_decl = decl = gfc_get_symbol_decl (sym);
/* Intrinsic scalars with VALUE attribute which are passed by value
use a hidden argument to denote the present status. */
/* Walk function argument list to find hidden arg. */
cond = DECL_ARGUMENTS (DECL_CONTEXT (decl));
for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond))
- if (DECL_NAME (cond) == tree_name)
+ if (DECL_NAME (cond) == tree_name
+ && DECL_ARTIFICIAL (cond))
break;
gcc_assert (cond);
return cond;
}
- if (TREE_CODE (decl) != PARM_DECL)
+ /* Assumed-shape arrays use a local variable for the array data;
+ the actual PARAM_DECL is in a saved decl. As the local variable
+ is NULL, it can be checked instead, unless use_saved_desc is
+ requested. */
+
+ if (use_saved_desc && TREE_CODE (decl) != PARM_DECL)
{
- /* Array parameters use a temporary descriptor, we want the real
- parameter. */
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
|| GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
}
- cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, decl,
+ cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl,
fold_convert (TREE_TYPE (decl), null_pointer_node));
/* Fortran 2008 allows to pass null pointers and non-associated pointers
we thus also need to check the array descriptor. For BT_CLASS, it
can also occur for scalars and F2003 due to type->class wrapping and
class->class wrapping. Note further that BT_CLASS always uses an
- array descriptor for arrays, also for explicit-shape/assumed-size. */
+ array descriptor for arrays, also for explicit-shape/assumed-size.
+ For assumed-rank arrays, no local variable is generated, hence,
+ the following also applies with !use_saved_desc. */
- if (!sym->attr.allocatable
+ if ((use_saved_desc || TREE_CODE (orig_decl) == PARM_DECL)
+ && !sym->attr.allocatable
&& ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
|| (sym->ts.type == BT_CLASS
&& !CLASS_DATA (sym)->attr.allocatable
if (tmp != NULL_TREE)
{
- tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
+ tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
fold_convert (TREE_TYPE (tmp), null_pointer_node));
cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
- boolean_type_node, cond, tmp);
+ logical_type_node, cond, tmp);
}
}
{
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);
gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
- se.expr, build_int_cst (gfc_charlen_type_node, 0));
+ se.expr, build_zero_cst (TREE_TYPE (se.expr)));
gfc_add_block_to_block (pblock, &se.pre);
if (cl->backend_decl)
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,
se->expr);
- tmp = gfc_build_array_ref (tmp, start.expr, NULL);
- se->expr = gfc_build_addr_expr (type, tmp);
+ /* For BIND(C), a BT_CHARACTER is not an ARRAY_TYPE. */
+ if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
+ {
+ tmp = gfc_build_array_ref (tmp, start.expr, NULL);
+ se->expr = gfc_build_addr_expr (type, tmp);
+ }
}
/* Length = end + 1 - start. */
if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
{
tree nonempty = fold_build2_loc (input_location, LE_EXPR,
- boolean_type_node, start.expr,
+ logical_type_node, start.expr,
end.expr);
/* Check lower bound. */
- fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
start.expr,
- build_int_cst (gfc_charlen_type_node, 1));
+ build_one_cst (TREE_TYPE (start.expr)));
fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
- boolean_type_node, nonempty, fault);
+ logical_type_node, nonempty, fault);
if (name)
msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
"is less than one", name);
free (msg);
/* Check upper bound. */
- fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+ fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
end.expr, se->string_length);
fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
- boolean_type_node, nonempty, fault);
+ logical_type_node, nonempty, fault);
if (name)
msg = xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
"exceeds string length (%%ld)", name);
if (ref->u.ss.end
&& gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
{
- int i_len;
+ HOST_WIDE_INT i_len;
- i_len = mpz_get_si (length) + 1;
+ i_len = gfc_mpz_get_hwi (length) + 1;
if (i_len < 0)
i_len = 0;
else
{
tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
- end.expr, start.expr);
+ fold_convert (gfc_charlen_type_node, end.expr),
+ fold_convert (gfc_charlen_type_node, start.expr));
tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
build_int_cst (gfc_charlen_type_node, 1), tmp);
tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
/* Convert a derived type component reference. */
-static void
+void
gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
{
gfc_component *c;
/* Allocatable deferred char arrays are to be handled by the gfc_deferred_
strlen () conditional below. */
if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
- && !(c->attr.allocatable && c->ts.deferred))
+ && !(c->attr.allocatable && c->ts.deferred)
+ && !c->attr.pdt_string)
{
tmp = c->ts.u.cl->backend_decl;
/* Components must always be constant length. */
/* This function deals with component references to components of the
parent type for derived type extensions. */
-static void
+void
conv_parent_component_references (gfc_se * se, gfc_ref * ref)
{
gfc_component *c;
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;
+}
+
+/* Dereference VAR where needed if it is a pointer, reference, etc.
+ according to Fortran semantics. */
+
+tree
+gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p,
+ bool is_classarray)
+{
+ /* Characters are entirely different from other types, they are treated
+ separately. */
+ if (sym->ts.type == BT_CHARACTER)
+ {
+ /* Dereference character pointer dummy arguments
+ or results. */
+ if ((sym->attr.pointer || sym->attr.allocatable
+ || (sym->as && sym->as->type == AS_ASSUMED_RANK))
+ && (sym->attr.dummy
+ || sym->attr.function
+ || sym->attr.result))
+ var = build_fold_indirect_ref_loc (input_location, var);
+ }
+ else if (!sym->attr.value)
+ {
+ /* Dereference temporaries for class array dummy arguments. */
+ if (sym->attr.dummy && is_classarray
+ && GFC_ARRAY_TYPE_P (TREE_TYPE (var)))
+ {
+ if (!descriptor_only_p)
+ var = GFC_DECL_SAVED_DESCRIPTOR (var);
+
+ var = build_fold_indirect_ref_loc (input_location, var);
+ }
+
+ /* Dereference non-character scalar dummy arguments. */
+ if (sym->attr.dummy && !sym->attr.dimension
+ && !(sym->attr.codimension && sym->attr.allocatable)
+ && (sym->ts.type != BT_CLASS
+ || (!CLASS_DATA (sym)->attr.dimension
+ && !(CLASS_DATA (sym)->attr.codimension
+ && CLASS_DATA (sym)->attr.allocatable))))
+ var = build_fold_indirect_ref_loc (input_location, var);
+
+ /* Dereference scalar hidden result. */
+ if (flag_f2c && sym->ts.type == BT_COMPLEX
+ && (sym->attr.function || sym->attr.result)
+ && !sym->attr.dimension && !sym->attr.pointer
+ && !sym->attr.always_explicit)
+ var = build_fold_indirect_ref_loc (input_location, var);
+
+ /* Dereference non-character, non-class pointer variables.
+ These must be dummies, results, or scalars. */
+ if (!is_classarray
+ && (sym->attr.pointer || sym->attr.allocatable
+ || gfc_is_associate_pointer (sym)
+ || (sym->as && sym->as->type == AS_ASSUMED_RANK))
+ && (sym->attr.dummy
+ || sym->attr.function
+ || sym->attr.result
+ || (!sym->attr.dimension
+ && (!sym->attr.codimension || !sym->attr.allocatable))))
+ var = build_fold_indirect_ref_loc (input_location, var);
+ /* Now treat the class array pointer variables accordingly. */
+ else if (sym->ts.type == BT_CLASS
+ && sym->attr.dummy
+ && (CLASS_DATA (sym)->attr.dimension
+ || CLASS_DATA (sym)->attr.codimension)
+ && ((CLASS_DATA (sym)->as
+ && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
+ || CLASS_DATA (sym)->attr.allocatable
+ || CLASS_DATA (sym)->attr.class_pointer))
+ var = build_fold_indirect_ref_loc (input_location, var);
+ /* And the case where a non-dummy, non-result, non-function,
+ non-allotable and non-pointer classarray is present. This case was
+ previously covered by the first if, but with introducing the
+ condition !is_classarray there, that case has to be covered
+ explicitly. */
+ else if (sym->ts.type == BT_CLASS
+ && !sym->attr.dummy
+ && !sym->attr.function
+ && !sym->attr.result
+ && (CLASS_DATA (sym)->attr.dimension
+ || CLASS_DATA (sym)->attr.codimension)
+ && (sym->assoc
+ || !CLASS_DATA (sym)->attr.allocatable)
+ && !CLASS_DATA (sym)->attr.class_pointer)
+ var = build_fold_indirect_ref_loc (input_location, var);
+ }
+
+ return var;
+}
+
/* Return the contents of a variable. Also handles reference/pointer
variables (all Fortran pointer references are implicit). */
return;
}
-
- /* Dereference the expression, where needed. Since characters
- are entirely different from other types, they are treated
- separately. */
- if (sym->ts.type == BT_CHARACTER)
- {
- /* Dereference character pointer dummy arguments
- or results. */
- if ((sym->attr.pointer || sym->attr.allocatable)
- && (sym->attr.dummy
- || sym->attr.function
- || sym->attr.result))
- se->expr = build_fold_indirect_ref_loc (input_location,
- se->expr);
-
- }
- else if (!sym->attr.value)
- {
- /* Dereference temporaries for class array dummy arguments. */
- if (sym->attr.dummy && is_classarray
- && GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr)))
- {
- if (!se->descriptor_only)
- se->expr = GFC_DECL_SAVED_DESCRIPTOR (se->expr);
-
- se->expr = build_fold_indirect_ref_loc (input_location,
- se->expr);
- }
-
- /* Dereference non-character scalar dummy arguments. */
- if (sym->attr.dummy && !sym->attr.dimension
- && !(sym->attr.codimension && sym->attr.allocatable)
- && (sym->ts.type != BT_CLASS
- || (!CLASS_DATA (sym)->attr.dimension
- && !(CLASS_DATA (sym)->attr.codimension
- && CLASS_DATA (sym)->attr.allocatable))))
- se->expr = build_fold_indirect_ref_loc (input_location,
- se->expr);
-
- /* Dereference scalar hidden result. */
- if (flag_f2c && sym->ts.type == BT_COMPLEX
- && (sym->attr.function || sym->attr.result)
- && !sym->attr.dimension && !sym->attr.pointer
- && !sym->attr.always_explicit)
- se->expr = build_fold_indirect_ref_loc (input_location,
- se->expr);
-
- /* Dereference non-character, non-class pointer variables.
- These must be dummies, results, or scalars. */
- if (!is_classarray
- && (sym->attr.pointer || sym->attr.allocatable
- || gfc_is_associate_pointer (sym)
- || (sym->as && sym->as->type == AS_ASSUMED_RANK))
- && (sym->attr.dummy
- || sym->attr.function
- || sym->attr.result
- || (!sym->attr.dimension
- && (!sym->attr.codimension || !sym->attr.allocatable))))
- se->expr = build_fold_indirect_ref_loc (input_location,
- se->expr);
- /* Now treat the class array pointer variables accordingly. */
- else if (sym->ts.type == BT_CLASS
- && sym->attr.dummy
- && (CLASS_DATA (sym)->attr.dimension
- || CLASS_DATA (sym)->attr.codimension)
- && ((CLASS_DATA (sym)->as
- && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
- || CLASS_DATA (sym)->attr.allocatable
- || CLASS_DATA (sym)->attr.class_pointer))
- se->expr = build_fold_indirect_ref_loc (input_location,
- se->expr);
- /* And the case where a non-dummy, non-result, non-function,
- non-allotable and non-pointer classarray is present. This case was
- previously covered by the first if, but with introducing the
- condition !is_classarray there, that case has to be covered
- explicitly. */
- else if (sym->ts.type == BT_CLASS
- && !sym->attr.dummy
- && !sym->attr.function
- && !sym->attr.result
- && (CLASS_DATA (sym)->attr.dimension
- || CLASS_DATA (sym)->attr.codimension)
- && (sym->assoc
- || !CLASS_DATA (sym)->attr.allocatable)
- && !CLASS_DATA (sym)->attr.class_pointer)
- se->expr = build_fold_indirect_ref_loc (input_location,
- se->expr);
- }
+ /* Dereference the expression, where needed. */
+ se->expr = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only,
+ is_classarray);
ref = expr->ref;
}
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 rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
{
- tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
lhs, build_int_cst (TREE_TYPE (lhs), -1));
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
lhs, build_int_cst (TREE_TYPE (lhs), 1));
/* If rhs is even,
if ((n & 1) == 0)
{
tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
- boolean_type_node, tmp, cond);
+ logical_type_node, tmp, cond);
se->expr = fold_build3_loc (input_location, COND_EXPR, type,
tmp, build_int_cst (type, 1),
build_int_cst (type, 0));
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
{
/* Create a temporary variable to hold the result. */
tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_charlen_type_node, len,
- build_int_cst (gfc_charlen_type_node, 1));
- tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
+ TREE_TYPE (len), len,
+ build_int_cst (TREE_TYPE (len), 1));
+ tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp);
if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
if (len == NULL_TREE)
{
len = fold_build2_loc (input_location, PLUS_EXPR,
- TREE_TYPE (lse.string_length),
- lse.string_length, rse.string_length);
+ gfc_charlen_type_node,
+ fold_convert (gfc_charlen_type_node,
+ lse.string_length),
+ fold_convert (gfc_charlen_type_node,
+ rse.string_length));
}
type = build_pointer_type (type);
return;
case INTRINSIC_AND:
- code = TRUTH_ANDIF_EXPR;
+ code = flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR;
lop = 1;
break;
case INTRINSIC_OR:
- code = TRUTH_ORIF_EXPR;
+ code = flag_frontend_optimize ? TRUTH_ORIF_EXPR : TRUTH_OR_EXPR;
lop = 1;
break;
if (lop)
{
- /* The result of logical ops is always boolean_type_node. */
- tmp = fold_build2_loc (input_location, code, boolean_type_node,
+ /* The result of logical ops is always logical_type_node. */
+ tmp = fold_build2_loc (input_location, code, logical_type_node,
lse.expr, rse.expr);
se->expr = convert (type, tmp);
}
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:
if (arg2 && arg2->expr_type == EXPR_CONSTANT)
d = mpz_get_si (arg2->value.integer) - 1;
else
- /* TODO: If the need arises, this could produce an array of
- ubound/lbounds. */
- gcc_unreachable ();
+ return false;
if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
{
if (expr->value.function.esym == NULL
&& expr->value.function.isym != NULL
+ && expr->value.function.actual
+ && expr->value.function.actual->expr
&& expr->value.function.actual->expr->symtree
&& gfc_map_intrinsic_function (expr, mapping))
break;
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);
/* Reset the offset for the function call since the loop
is zero based on the data pointer. Note that the temp
comes first in the loop chain since it is added second. */
- if (gfc_is_alloc_class_array_function (expr))
+ if (gfc_is_class_array_function (expr))
{
tmp = loop.ss->loop_chain->info->data.array.descriptor;
gfc_conv_descriptor_offset_set (&loop.pre, tmp,
dimen = rse.ss->dimen;
/* Skip the write-out loop for this case. */
- if (gfc_is_alloc_class_array_function (expr))
+ if (gfc_is_class_array_function (expr))
goto class_array_fcn;
/* Calculate the bounds of the scalarization. */
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.
gcc_assert ((!comp && gfc_return_by_reference (sym)
&& sym->result->attr.dimension)
|| (comp && comp->attr.dimension)
- || gfc_is_alloc_class_array_function (expr));
+ || gfc_is_class_array_function (expr));
gcc_assert (se->loop != NULL);
/* Access the previously obtained result. */
gfc_conv_tmp_array_ref (se);
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,
tree descriptor_data;
descriptor_data = ss->info->data.array.data;
- tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
descriptor_data,
fold_convert (TREE_TYPE (descriptor_data),
null_pointer_node));
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
fold_convert (TREE_TYPE (parmse.expr),
integer_zero_node));
- vec_safe_push (optionalargs, tmp);
+ vec_safe_push (optionalargs,
+ fold_convert (boolean_type_node,
+ tmp));
}
}
}
}
+
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
tree cond;
tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
cond = fold_build2_loc (input_location, NE_EXPR,
- boolean_type_node, tmp,
+ logical_type_node, tmp,
fold_convert (TREE_TYPE (tmp),
null_pointer_node));
gfc_start_block (&block);
}
}
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,
&& fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
{
tmp = parmse.expr;
- if (TREE_CODE (tmp) == ADDR_EXPR
- && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp, 0))))
- tmp = TREE_OPERAND (tmp, 0);
+ if (TREE_CODE (tmp) == ADDR_EXPR)
+ tmp = build_fold_indirect_ref_loc (input_location, tmp);
parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
fsym->attr);
parmse.expr = gfc_build_addr_expr (NULL_TREE,
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)
+ && fsym && fsym->ts.type == BT_DERIVED)
/* The actual argument is a component reference to an
array of derived types. In this case, the argument
is converted to a temporary, which is passed and then
the same as the declared type, copy-in/copy-out does
not occur. */
gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
- fsym ? fsym->attr.intent : INTENT_INOUT,
- fsym && fsym->attr.pointer);
+ fsym->attr.intent,
+ fsym->attr.pointer);
- else if (gfc_is_alloc_class_array_function (e)
- && fsym && fsym->ts.type == BT_DERIVED)
+ else if (gfc_is_class_array_function (e)
+ && fsym && fsym->ts.type == BT_DERIVED)
/* See previous comment. For function actual argument,
the write out is not needed so the intent is set as
intent in. */
{
e->must_finalize = 1;
gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
- INTENT_IN,
- fsym && fsym->attr.pointer);
+ INTENT_IN, fsym->attr.pointer);
+ }
+ else if (fsym && fsym->attr.contiguous
+ && !gfc_is_simply_contiguous (e, false, true)
+ && gfc_expr_is_variable (e))
+ {
+ gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
+ fsym->attr.intent,
+ 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->ref
+ && e->ref->u.ar.type == AR_FULL
+ && 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
present = gfc_conv_expr_present (e->symtree->n.sym);
type = TREE_TYPE (present);
present = fold_build2_loc (input_location, EQ_EXPR,
- boolean_type_node, present,
+ logical_type_node, present,
fold_convert (type,
null_pointer_node));
type = TREE_TYPE (parmse.expr);
null_ptr = fold_build2_loc (input_location, EQ_EXPR,
- boolean_type_node, parmse.expr,
+ logical_type_node, parmse.expr,
fold_convert (type,
null_pointer_node));
cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
- boolean_type_node, present, null_ptr);
+ logical_type_node, present, null_ptr);
}
else
{
tmp = gfc_build_addr_expr (NULL_TREE, tmp);
cond = fold_build2_loc (input_location, EQ_EXPR,
- boolean_type_node, tmp,
+ logical_type_node, tmp,
fold_convert (TREE_TYPE (tmp),
null_pointer_node));
}
/* 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)
{
if (ts.u.cl->length == NULL)
{
- /* Assumed character length results are not allowed by 5.1.1.5 of the
+ /* Assumed character length results are not allowed by C418 of the 2003
standard and are trapped in resolve.c; except in the case of SPREAD
(and other intrinsics?) and dummy functions. In the case of SPREAD,
we take the character length of the first argument for the result.
gfc_conv_expr (&parmse, ts.u.cl->length);
gfc_add_block_to_block (&se->pre, &parmse.pre);
gfc_add_block_to_block (&se->post, &parmse.post);
-
- tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
+ tmp = parmse.expr;
+ /* TODO: It would be better to have the charlens as
+ gfc_charlen_type_node already when the interface is
+ created instead of converting it here (see PR 84615). */
tmp = fold_build2_loc (input_location, MAX_EXPR,
- gfc_charlen_type_node, tmp,
- build_int_cst (gfc_charlen_type_node, 0));
+ gfc_charlen_type_node,
+ fold_convert (gfc_charlen_type_node, tmp),
+ build_zero_cst (gfc_charlen_type_node));
cl.backend_decl = tmp;
}
/* 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);
happen in a function returning a pointer. */
tmp = gfc_conv_descriptor_data_get (info->descriptor);
tmp = fold_build2_loc (input_location, NE_EXPR,
- boolean_type_node,
+ logical_type_node,
tmp, info->data);
gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
gfc_msg_fault);
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. */
call the finalization function of the temporary. Note that the
nullification of allocatable components needed by the result
is done in gfc_trans_assignment_1. */
- if (expr && ((gfc_is_alloc_class_array_function (expr)
+ if (expr && ((gfc_is_class_array_function (expr)
&& se->ss && se->ss->loop)
|| gfc_is_alloc_class_scalar_function (expr))
&& se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
int n;
if (se->ss && se->ss->loop)
{
+ gfc_add_block_to_block (&se->ss->loop->pre, &se->pre);
se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre);
tmp = gfc_class_data_get (se->expr);
info->descriptor = tmp;
CLASS_DATA (expr->value.function.esym->result)->attr);
}
+ if ((gfc_is_class_array_function (expr)
+ || gfc_is_alloc_class_scalar_function (expr))
+ && CLASS_DATA (expr->value.function.esym->result)->attr.pointer)
+ goto no_finalization;
+
final_fndecl = gfc_class_vtab_final_get (se->expr);
is_final = fold_build2_loc (input_location, NE_EXPR,
- boolean_type_node,
- final_fndecl,
+ logical_type_node,
+ 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);
}
- expr->must_finalize = 0;
}
+no_finalization:
gfc_add_block_to_block (&se->post, &post);
}
3, start,
build_int_cst (gfc_get_int_type (gfc_c_int_kind),
lang_hooks.to_target_charset (' ')),
- size);
+ fold_convert (size_type_node, size));
/* Otherwise, we use a loop:
for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
gfc_init_block (&loop);
/* Exit condition. */
- cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, i,
+ cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i,
build_zero_cst (sizetype));
tmp = build1_v (GOTO_EXPR, exit_label);
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
if (slength != NULL_TREE)
{
- slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
+ slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block);
ssc = gfc_string_to_single_character (slen, src, skind);
}
else
{
- slen = build_int_cst (size_type_node, 1);
+ slen = build_one_cst (gfc_charlen_type_node);
ssc = src;
}
if (dlength != NULL_TREE)
{
- dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
+ dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block);
dsc = gfc_string_to_single_character (dlen, dest, dkind);
}
else
{
- dlen = build_int_cst (size_type_node, 1);
+ dlen = build_one_cst (gfc_charlen_type_node);
dsc = dest;
}
/* 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);
- }
+ if (destlen > 0)
+ {
+ if (srclen < destlen)
+ {
+ memmove (dest, src, srclen);
+ // Pad with spaces.
+ memset (&dest[srclen], ' ', destlen - srclen);
+ }
+ else
+ {
+ // Truncate if too long.
+ memmove (dest, src, destlen);
+ }
+ }
*/
/* 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));
+ cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen,
+ build_zero_cst (TREE_TYPE (dlen)));
/* For non-default character kinds, we have to multiply the string
length by the base type size. */
chartype = gfc_get_char_type (dkind);
- slen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
- fold_convert (size_type_node, slen),
- fold_convert (size_type_node,
+ slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen),
+ slen,
+ fold_convert (TREE_TYPE (slen),
TYPE_SIZE_UNIT (chartype)));
- dlen = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
- fold_convert (size_type_node, dlen),
- fold_convert (size_type_node,
+ dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen),
+ dlen,
+ fold_convert (TREE_TYPE (dlen),
TYPE_SIZE_UNIT (chartype)));
if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
else
src = gfc_build_addr_expr (pvoid_type_node, src);
- /* 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, tmp2);
- stmtblock_t tmpblock2;
- gfc_init_block (&tmpblock2);
- gfc_add_expr_to_block (&tmpblock2, tmp2);
-
- /* If the destination is longer, fill the end with spaces. */
- cond2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, slen,
+ /* Truncate string if source is too long. */
+ cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen,
dlen);
+ /* Copy and pad with spaces. */
+ tmp3 = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_MEMMOVE),
+ 3, dest, src,
+ fold_convert (size_type_node, slen));
+
/* Wstringop-overflow appears at -O3 even though this warning is not
explicitly available in fortran nor can it be switched off. If the
source length is a constant, its negative appears as a very large
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 truncated memmove if the slen >= dlen. */
+ tmp2 = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_MEMMOVE),
+ 3, dest, src,
+ fold_convert (size_type_node, dlen));
+
/* The whole copy_string function is there. */
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
- tmp3, build_empty_stmt (input_location));
- gfc_add_expr_to_block (&tmpblock2, tmp);
- tmp = gfc_finish_block (&tmpblock2);
+ tmp3, tmp2);
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 (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. */
- 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)
null_pointer_node);
null_expr = gfc_finish_block (&block);
tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
- tmp = build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
+ tmp = build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
fold_convert (TREE_TYPE (tmp), null_pointer_node));
return build3_v (COND_EXPR, tmp,
null_expr, non_null_expr);
if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
/* Update the lhs character length. */
- gfc_add_modify (block, lhs_cl_size, size);
+ gfc_add_modify (block, lhs_cl_size,
+ fold_convert (TREE_TYPE (lhs_cl_size), size));
}
1, size);
gfc_add_modify (&block, dest,
fold_convert (TREE_TYPE (dest), tmp));
- gfc_add_modify (&block, strlen, se.string_length);
+ gfc_add_modify (&block, strlen,
+ fold_convert (TREE_TYPE (strlen), se.string_length));
tmp = gfc_build_memcpy_call (dest, se.expr, size);
gfc_add_expr_to_block (&block, tmp);
}
gfc_se se;
gfc_start_block (&block);
- cm = expr->ts.u.derived->components;
if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
&& (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
return gfc_finish_block (&block);
}
+ /* Make sure that the derived type has been completely built. */
+ if (!expr->ts.u.derived->backend_decl
+ || !TYPE_FIELDS (expr->ts.u.derived->backend_decl))
+ {
+ tmp = gfc_typenode_for_spec (&expr->ts);
+ gcc_assert (tmp);
+ }
+
+ cm = expr->ts.u.derived->components;
+
+
if (coarray)
gfc_init_se (&se, NULL);
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_dtype (desc),
- build_int_cst (gfc_array_index_type, rank));
+ gfc_add_modify (&block, gfc_conv_descriptor_rank (desc),
+ build_int_cst (signed_char_type_node, rank));
}
else
{
gfc_add_expr_to_block (&block, tmp);
}
field = cm->backend_decl;
+ gcc_assert(field);
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
dest, field, NULL_TREE);
if (!c->expr)
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;
}
if (expr->expr_type == EXPR_FUNCTION
&& ((expr->value.function.esym
+ && expr->value.function.esym->result
&& expr->value.function.esym->result->attr.pointer
&& !expr->value.function.esym->result->attr.dimension)
|| (!expr->value.function.esym && !expr->ref
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);
{
vptr_expr = NULL;
se.expr = gfc_class_vptr_get (rse->expr);
+ if (UNLIMITED_POLY (re))
+ from_len = gfc_class_len_get (rse->expr);
}
else if (re->expr_type != EXPR_NULL)
/* Only when rhs is non-NULL use its declared type for vptr
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);
from_len = gfc_evaluate_now (se.expr, block);
}
else
- from_len = integer_zero_node;
+ from_len = build_zero_cst (gfc_charlen_type_node);
}
gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
from_len));
}
}
-/* 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);
if (expr1->ts.deferred)
{
if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
- gfc_add_modify (&block, lse.string_length, rse.string_length);
+ gfc_add_modify (&block, lse.string_length,
+ fold_convert (TREE_TYPE (lse.string_length),
+ rse.string_length));
else if (lse.string_length != NULL)
gfc_add_modify (&block, lse.string_length,
- build_int_cst (gfc_charlen_type_node, 0));
+ build_zero_cst (TREE_TYPE (lse.string_length)));
}
gfc_add_modify (&block, lse.expr,
break;
rank_remap = (remap && remap->u.ar.end[0]);
+ if (remap && expr2->expr_type == EXPR_NULL)
+ {
+ gfc_error ("If bounds remapping is specified at %L, "
+ "the pointer target shall not be NULL", &expr1->where);
+ return NULL_TREE;
+ }
+
gfc_init_se (&lse, NULL);
if (remap)
lse.descriptor_only = 1;
}
}
- /* 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))
lsize = gfc_evaluate_now (lsize, &block);
rsize = gfc_evaluate_now (rsize, &block);
- fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
rsize, lsize);
msg = _("Target of rank remapping is too small (%ld < %ld)");
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)
{
gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
rse->expr, ts.kind);
}
- else if (gfc_bt_struct (ts.type) && ts.u.derived->attr.alloc_comp)
+ else if (gfc_bt_struct (ts.type)
+ && (ts.u.derived->attr.alloc_comp
+ || (deep_copy && ts.u.derived->attr.pdt_type)))
{
tree tmp_var = NULL_TREE;
cond = NULL_TREE;
/* Are the rhs and the lhs the same? */
if (deep_copy)
{
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
gfc_build_addr_expr (NULL_TREE, lse->expr),
gfc_build_addr_expr (NULL_TREE, rse->expr));
cond = gfc_evaluate_now (cond, &lse->pre);
gfc_symbol *sym = expr1->symtree->n.sym;
/* Play it safe with class functions assigned to a derived type. */
- if (gfc_is_alloc_class_array_function (expr2)
+ if (gfc_is_class_array_function (expr2)
&& expr1->ts.type == BT_DERIVED)
return true;
/* If we have reached here with an intrinsic function, we do not
need a temporary except in the particular case that reallocation
- on assignment is active and the lhs is allocatable and a target. */
+ on assignment is active and the lhs is allocatable and a target,
+ or a pointer which may be a subref pointer. FIXME: The last
+ condition can go away when we use span in the intrinsics
+ directly.*/
if (expr2->value.function.isym)
- return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target);
+ return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target)
+ || (sym->attr.pointer && sym->attr.subref_array_pointer);
/* If the LHS is a dummy, we need a temporary if it is not
INTENT(OUT). */
the lhs descriptor. */
tmp = gfc_conv_descriptor_data_get (desc);
zero_cond = fold_build2_loc (input_location, EQ_EXPR,
- boolean_type_node, tmp,
+ logical_type_node, tmp,
build_int_cst (TREE_TYPE (tmp), 0));
zero_cond = gfc_evaluate_now (zero_cond, &se->post);
tmp = gfc_call_free (tmp);
tmp = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, tmp, tmp1);
tmp = fold_build2_loc (input_location, NE_EXPR,
- boolean_type_node, tmp,
+ logical_type_node, tmp,
gfc_index_zero_node);
tmp = gfc_evaluate_now (tmp, &se->post);
zero_cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
- boolean_type_node, tmp,
+ logical_type_node, tmp,
zero_cond);
}
/* 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);
}
/* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
- cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
lse.expr, tmp);
tmp = build3_v (COND_EXPR, cond,
build1_v (GOTO_EXPR, jump_label1),
rhs are different. */
if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
{
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
- lse.string_length, size);
+ cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
+ lse.string_length,
+ fold_convert (TREE_TYPE (lse.string_length),
+ size));
/* Jump past the realloc if the lengths are the same. */
tmp = build3_v (COND_EXPR, cond,
build1_v (GOTO_EXPR, jump_label2),
/* Update the lhs character length. */
size = string_length;
- gfc_add_modify (block, lse.string_length, size);
+ gfc_add_modify (block, lse.string_length,
+ fold_convert (TREE_TYPE (lse.string_length), size));
}
}
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,
+ logical_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,
extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
tmp = fold_build2_loc (input_location, GT_EXPR,
- boolean_type_node, from_len,
- integer_zero_node);
+ logical_type_node, from_len,
+ build_zero_cst (TREE_TYPE (from_len)));
return fold_build3_loc (input_location, COND_EXPR,
void_type_node, tmp,
extcopy, stdcopy);
/* Walk the lhs. */
lss = gfc_walk_expr (expr1);
- if (gfc_is_reallocatable_lhs (expr1)
- && !(expr2->expr_type == EXPR_FUNCTION
- && expr2->value.function.isym != NULL))
- lss->is_alloc_lhs = 1;
+ if (gfc_is_reallocatable_lhs (expr1))
+ {
+ lss->no_bounds_check = 1;
+ if (!(expr2->expr_type == EXPR_FUNCTION
+ && expr2->value.function.isym != NULL
+ && !(expr2->value.function.isym->elemental
+ || expr2->value.function.isym->conversion)))
+ lss->is_alloc_lhs = 1;
+ }
+ else
+ lss->no_bounds_check = expr1->no_bounds_check;
+
rss = NULL;
if ((expr1->ts.type == BT_DERIVED)
- && (gfc_is_alloc_class_array_function (expr2)
+ && (gfc_is_class_array_function (expr2)
|| gfc_is_alloc_class_scalar_function (expr2)))
expr2->must_finalize = 1;
if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
rss->info->type = GFC_SS_REFERENCE;
+ rss->no_bounds_check = expr2->no_bounds_check;
/* Associate the SS with the loop. */
gfc_add_ss_to_loop (&loop, lss);
gfc_add_ss_to_loop (&loop, rss);
|| 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;
if (TREE_CODE (lse.expr) == ARRAY_REF)
tmp = gfc_build_addr_expr (NULL_TREE, tmp);
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
tmp, build_int_cst (TREE_TYPE (tmp), 0));
msg = _("Assignment of scalar to unallocated array");
gfc_trans_runtime_check (true, false, cond, &loop.pre,
&expr1->where, msg);
}
+
+ /* Deallocate the lhs parameterized components if required. */
+ if (dealloc && expr2->expr_type == EXPR_FUNCTION
+ && !expr1->symtree->n.sym->attr.associate_var)
+ {
+ if (expr1->ts.type == BT_DERIVED
+ && expr1->ts.u.derived
+ && expr1->ts.u.derived->attr.pdt_type)
+ {
+ tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, lse.expr,
+ expr1->rank);
+ gfc_add_expr_to_block (&lse.pre, tmp);
+ }
+ else if (expr1->ts.type == BT_CLASS
+ && CLASS_DATA (expr1)->ts.u.derived
+ && CLASS_DATA (expr1)->ts.u.derived->attr.pdt_type)
+ {
+ tmp = gfc_class_data_get (lse.expr);
+ tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
+ tmp, expr1->rank);
+ gfc_add_expr_to_block (&lse.pre, tmp);
+ }
+ }
}
/* Assignments of scalar derived types with allocatable components
/* 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
a scalar to array assignment, this is done in gfc_trans_scalar_assign
as part of the deep copy. */
if (!scalar_to_array && expr1->ts.type == BT_DERIVED
- && (gfc_is_alloc_class_array_function (expr2)
+ && (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);
return tmp;
}
+ if (UNLIMITED_POLY (expr1) && expr1->rank
+ && expr2->ts.type != BT_CLASS)
+ use_vptr_copy = true;
+
/* Fallback to the scalarizer to generate explicit loops. */
return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
use_vptr_copy, may_alias);
projects / gcc.git / blobdiff