Chromium Code Reviews
chromiumcodereview-hr@appspot.gserviceaccount.com (chromiumcodereview-hr) | Please choose your nickname with Settings | Help | Chromium Project | Gerrit Changes | Sign out
(393)

Issues Search
    My Issues | Starred     Open | Closed | All

Unified Diff: gcc/gcc/fortran/trans-expr.c

Issue 3050029: [gcc] GCC 4.5.0=>4.5.1 (Closed) Base URL: ssh://git@gitrw.chromium.org:9222/nacl-toolchain.git
Patch Set: Created 10 years, 5 months ago
Use n/p to move between diff chunks; N/P to move between comments. Draft comments are only viewable by you.
Jump to:
View side-by-side diff with in-line comments
Download patch
« no previous file with comments | « gcc/gcc/fortran/trans-decl.c ('k') | gcc/gcc/fortran/trans-intrinsic.c » ('j') | no next file with comments »
Expand Comments ('e') | Collapse Comments ('c') | Show Comments Hide Comments ('s')
Index: gcc/gcc/fortran/trans-expr.c
diff --git a/gcc/gcc/fortran/trans-expr.c b/gcc/gcc/fortran/trans-expr.c
index 98abf9ed1da484dd22417cf11b5a38b2998d3ef5..647df72e580dc052729884a699df6a48138b2fd2 100644
--- a/gcc/gcc/fortran/trans-expr.c
+++ b/gcc/gcc/fortran/trans-expr.c
@@ -1,5 +1,5 @@
/* Expression translation
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
@@ -158,13 +158,14 @@ gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
{
/* Create a temporary and convert it to the correct type. */
tmp = gfc_get_int_type (kind);
- tmp = fold_convert (tmp, build_fold_indirect_ref (se->expr));
+ tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
+ se->expr));
/* Test for a NULL value. */
tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, tmp,
fold_convert (TREE_TYPE (tmp), integer_one_node));
tmp = gfc_evaluate_now (tmp, &se->pre);
- se->expr = build_fold_addr_expr (tmp);
+ se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
}
else
{
@@ -200,12 +201,12 @@ gfc_get_expr_charlen (gfc_expr *e)
length = NULL; /* To silence compiler warning. */
- if (is_subref_array (e) && e->ts.cl->length)
+ if (is_subref_array (e) && e->ts.u.cl->length)
{
gfc_se tmpse;
gfc_init_se (&tmpse, NULL);
- gfc_conv_expr_type (&tmpse, e->ts.cl->length, gfc_charlen_type_node);
- e->ts.cl->backend_decl = tmpse.expr;
+ gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
+ e->ts.u.cl->backend_decl = tmpse.expr;
return tmpse.expr;
}
@@ -213,7 +214,7 @@ gfc_get_expr_charlen (gfc_expr *e)
expression's length could be the length of the character
variable. */
if (e->symtree->n.sym->ts.type == BT_CHARACTER)
- length = e->symtree->n.sym->ts.cl->backend_decl;
+ length = e->symtree->n.sym->ts.u.cl->backend_decl;
/* Look through the reference chain for component references. */
for (r = e->ref; r; r = r->next)
@@ -222,7 +223,7 @@ gfc_get_expr_charlen (gfc_expr *e)
{
case REF_COMPONENT:
if (r->u.c.component->ts.type == BT_CHARACTER)
- length = r->u.c.component->ts.cl->backend_decl;
+ length = r->u.c.component->ts.u.cl->backend_decl;
break;
case REF_ARRAY:
@@ -242,7 +243,7 @@ gfc_get_expr_charlen (gfc_expr *e)
}
-/* For each character array constructor subexpression without a ts.cl->length,
+/* For each character array constructor subexpression without a ts.u.cl->length,
replace it by its first element (if there aren't any elements, the length
should already be set to zero). */
@@ -275,7 +276,7 @@ flatten_array_ctors_without_strlen (gfc_expr* e)
case EXPR_ARRAY:
/* We've found what we're looking for. */
- if (e->ts.type == BT_CHARACTER && !e->ts.cl->length)
+ if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
{
gfc_expr* new_expr;
gcc_assert (e->value.constructor);
@@ -355,7 +356,6 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
{
tree tmp;
tree type;
- tree var;
tree fault;
gfc_se start;
gfc_se end;
@@ -364,7 +364,6 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
type = gfc_get_character_type (kind, ref->u.ss.length);
type = build_pointer_type (type);
- var = NULL_TREE;
gfc_init_se (&start, se);
gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
gfc_add_block_to_block (&se->pre, &start.pre);
@@ -373,15 +372,18 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
gfc_conv_string_parameter (se);
else
{
+ tmp = start.expr;
+ STRIP_NOPS (tmp);
/* Avoid multiple evaluation of substring start. */
- if (!CONSTANT_CLASS_P (start.expr) && !DECL_P (start.expr))
+ if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
start.expr = gfc_evaluate_now (start.expr, &se->pre);
/* Change the start of the string. */
if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
tmp = se->expr;
else
- tmp = build_fold_indirect_ref (se->expr);
+ 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);
}
@@ -395,10 +397,12 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
gfc_add_block_to_block (&se->pre, &end.pre);
}
- if (!CONSTANT_CLASS_P (end.expr) && !DECL_P (end.expr))
+ tmp = end.expr;
+ STRIP_NOPS (tmp);
+ if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
end.expr = gfc_evaluate_now (end.expr, &se->pre);
- if (flag_bounds_check)
+ if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
{
tree nonempty = fold_build2 (LE_EXPR, boolean_type_node,
start.expr, end.expr);
@@ -438,9 +442,9 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
}
tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node,
- build_int_cst (gfc_charlen_type_node, 1),
- start.expr);
- tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
+ end.expr, start.expr);
+ tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node,
+ build_int_cst (gfc_charlen_type_node, 1), tmp);
tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
build_int_cst (gfc_charlen_type_node, 0));
se->string_length = tmp;
@@ -468,16 +472,19 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
se->expr = tmp;
- if (c->ts.type == BT_CHARACTER)
+ if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
{
- tmp = c->ts.cl->backend_decl;
+ tmp = c->ts.u.cl->backend_decl;
/* Components must always be constant length. */
gcc_assert (tmp && INTEGER_CST_P (tmp));
se->string_length = tmp;
}
- if (c->attr.pointer && c->attr.dimension == 0 && c->ts.type != BT_CHARACTER)
- se->expr = build_fold_indirect_ref (se->expr);
+ if (((c->attr.pointer || c->attr.allocatable) && c->attr.dimension == 0
+ && c->ts.type != BT_CHARACTER)
+ || c->attr.proc_pointer)
+ se->expr = build_fold_indirect_ref_loc (input_location,
+ se->expr);
}
@@ -500,16 +507,23 @@ conv_parent_component_references (gfc_se * se, gfc_ref * ref)
parent.u.c.sym = dt;
parent.u.c.component = dt->components;
+ if (dt->backend_decl == NULL)
+ gfc_get_derived_type (dt);
+
if (dt->attr.extension && dt->components)
{
+ if (dt->attr.is_class)
+ cmp = dt->components;
+ else
+ cmp = dt->components->next;
/* Return if the component is not in the parent type. */
- for (cmp = dt->components->next; cmp; cmp = cmp->next)
+ for (; cmp; cmp = cmp->next)
if (strcmp (c->name, cmp->name) == 0)
return;
/* Otherwise build the reference and call self. */
gfc_conv_component_ref (se, &parent);
- parent.u.c.sym = dt->components->ts.derived;
+ parent.u.c.sym = dt->components->ts.u.derived;
parent.u.c.component = c;
conv_parent_component_references (se, &parent);
}
@@ -603,7 +617,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
if (!sym->attr.dummy && !sym->attr.proc_pointer)
{
gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
- se->expr = build_fold_addr_expr (se->expr);
+ se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
}
return;
}
@@ -620,21 +634,24 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
&& (sym->attr.dummy
|| sym->attr.function
|| sym->attr.result))
- se->expr = build_fold_indirect_ref (se->expr);
+ se->expr = build_fold_indirect_ref_loc (input_location,
+ se->expr);
}
else if (!sym->attr.value)
{
/* Dereference non-character scalar dummy arguments. */
if (sym->attr.dummy && !sym->attr.dimension)
- se->expr = build_fold_indirect_ref (se->expr);
+ se->expr = build_fold_indirect_ref_loc (input_location,
+ se->expr);
/* Dereference scalar hidden result. */
if (gfc_option.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 (se->expr);
+ se->expr = build_fold_indirect_ref_loc (input_location,
+ se->expr);
/* Dereference non-character pointer variables.
These must be dummies, results, or scalars. */
@@ -643,7 +660,8 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
|| sym->attr.function
|| sym->attr.result
|| !sym->attr.dimension))
- se->expr = build_fold_indirect_ref (se->expr);
+ se->expr = build_fold_indirect_ref_loc (input_location,
+ se->expr);
}
ref = expr->ref;
@@ -654,10 +672,10 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
{
/* If the character length of an entry isn't set, get the length from
the master function instead. */
- if (sym->attr.entry && !sym->ts.cl->backend_decl)
- se->string_length = sym->ns->proc_name->ts.cl->backend_decl;
+ if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
+ se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
else
- se->string_length = sym->ts.cl->backend_decl;
+ se->string_length = sym->ts.u.cl->backend_decl;
gcc_assert (se->string_length);
}
@@ -702,10 +720,10 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
separately. */
if (se->want_pointer)
{
- if (expr->ts.type == BT_CHARACTER)
+ if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
gfc_conv_string_parameter (se);
else
- se->expr = build_fold_addr_expr (se->expr);
+ se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
}
}
@@ -1079,7 +1097,8 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
break;
}
- se->expr = build_call_expr (fndecl, 2, lse.expr, rse.expr);
+ se->expr = build_call_expr_loc (input_location,
+ fndecl, 2, lse.expr, rse.expr);
}
@@ -1091,7 +1110,7 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
tree var;
tree tmp;
- gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
+ gcc_assert (types_compatible_p (TREE_TYPE (len), gfc_charlen_type_node));
if (gfc_can_put_var_on_stack (len))
{
@@ -1150,7 +1169,7 @@ gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
gfc_add_block_to_block (&se->pre, &lse.pre);
gfc_add_block_to_block (&se->pre, &rse.pre);
- type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
+ type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
if (len == NULL_TREE)
{
@@ -1170,7 +1189,8 @@ gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
else
gcc_unreachable ();
- tmp = build_call_expr (fndecl, 6, len, var, lse.string_length, lse.expr,
+ tmp = build_call_expr_loc (input_location,
+ fndecl, 6, len, var, lse.string_length, lse.expr,
rse.string_length, rse.expr);
gfc_add_expr_to_block (&se->pre, tmp);
@@ -1205,8 +1225,9 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
switch (expr->value.op.op)
{
case INTRINSIC_PARENTHESES:
- if (expr->ts.type == BT_REAL
- || expr->ts.type == BT_COMPLEX)
+ if ((expr->ts.type == BT_REAL
+ || expr->ts.type == BT_COMPLEX)
+ && gfc_option.flag_protect_parens)
{
gfc_conv_unary_op (PAREN_EXPR, se, expr);
gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
@@ -1377,7 +1398,8 @@ string_to_single_character (tree len, tree str, int kind)
&& TREE_INT_CST_HIGH (len) == 0)
{
str = fold_convert (gfc_get_pchar_type (kind), str);
- return build_fold_indirect_ref (str);
+ return build_fold_indirect_ref_loc (input_location,
+ str);
}
return NULL_TREE;
@@ -1480,22 +1502,173 @@ gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind)
else
gcc_unreachable ();
- tmp = build_call_expr (fndecl, 4, len1, str1, len2, str2);
+ tmp = build_call_expr_loc (input_location,
+ fndecl, 4, len1, str1, len2, str2);
}
return tmp;
}
+
+/* Return the backend_decl for a procedure pointer component. */
+
+static tree
+get_proc_ptr_comp (gfc_expr *e)
+{
+ gfc_se comp_se;
+ gfc_expr *e2;
+ gfc_init_se (&comp_se, NULL);
+ e2 = gfc_copy_expr (e);
+ e2->expr_type = EXPR_VARIABLE;
+ gfc_conv_expr (&comp_se, e2);
+ gfc_free_expr (e2);
+ return build_fold_addr_expr_loc (input_location, comp_se.expr);
+}
+
+
+/* Select a class typebound procedure at runtime. */
static void
-gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
+select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
+ tree declared, gfc_expr *expr)
{
+ tree end_label;
+ tree label;
tree tmp;
+ tree hash;
+ stmtblock_t body;
+ gfc_class_esym_list *next_elist, *tmp_elist;
+ gfc_se tmpse;
- if (sym->attr.dummy)
+ /* Convert the hash expression. */
+ gfc_init_se (&tmpse, NULL);
+ gfc_conv_expr (&tmpse, elist->hash_value);
+ gfc_add_block_to_block (&se->pre, &tmpse.pre);
+ hash = gfc_evaluate_now (tmpse.expr, &se->pre);
+ gfc_add_block_to_block (&se->post, &tmpse.post);
+
+ /* Fix the function type to be that of the declared type method. */
+ declared = gfc_create_var (TREE_TYPE (declared), "method");
+
+ end_label = gfc_build_label_decl (NULL_TREE);
+
+ gfc_init_block (&body);
+
+ /* Go through the list of extensions. */
+ for (; elist; elist = next_elist)
+ {
+ /* This case has already been added. */
+ if (elist->derived == NULL)
+ goto free_elist;
+
+ /* Skip abstract base types. */
+ if (elist->derived->attr.abstract)
+ goto free_elist;
+
+ /* Run through the chain picking up all the cases that call the
+ same procedure. */
+ tmp_elist = elist;
+ for (; elist; elist = elist->next)
+ {
+ tree cval;
+
+ if (elist->esym != tmp_elist->esym)
+ continue;
+
+ cval = build_int_cst (TREE_TYPE (hash),
+ elist->derived->hash_value);
+ /* Build a label for the hash value. */
+ label = gfc_build_label_decl (NULL_TREE);
+ tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
+ cval, NULL_TREE, label);
+ gfc_add_expr_to_block (&body, tmp);
+
+ /* Null the reference the derived type so that this case is
+ not used again. */
+ elist->derived = NULL;
+ }
+
+ elist = tmp_elist;
+
+ /* Get a pointer to the procedure, */
+ tmp = gfc_get_symbol_decl (elist->esym);
+ if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+ {
+ gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+ }
+
+ /* Assign the pointer to the appropriate procedure. */
+ gfc_add_modify (&body, declared,
+ fold_convert (TREE_TYPE (declared), tmp));
+
+ /* Break to the end of the construct. */
+ tmp = build1_v (GOTO_EXPR, end_label);
+ gfc_add_expr_to_block (&body, tmp);
+
+ /* Free the elists as we go; freeing them in gfc_free_expr causes
+ segfaults because it occurs too early and too often. */
+ free_elist:
+ next_elist = elist->next;
+ if (elist->hash_value)
+ gfc_free_expr (elist->hash_value);
+ gfc_free (elist);
+ elist = NULL;
+ }
+
+ /* Default is an error. */
+ label = gfc_build_label_decl (NULL_TREE);
+ tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
+ NULL_TREE, NULL_TREE, label);
+ gfc_add_expr_to_block (&body, tmp);
+ tmp = gfc_trans_runtime_error (true, &expr->where,
+ "internal error: bad hash value in dynamic dispatch");
+ gfc_add_expr_to_block (&body, tmp);
+
+ /* Write the switch expression. */
+ tmp = gfc_finish_block (&body);
+ tmp = build3_v (SWITCH_EXPR, hash, tmp, NULL_TREE);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ tmp = build1_v (LABEL_EXPR, end_label);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ se->expr = declared;
+ return;
+}
+
+
+static void
+conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
+{
+ tree tmp;
+
+ if (expr && expr->symtree
+ && expr->value.function.class_esym)
+ {
+ if (!sym->backend_decl)
+ sym->backend_decl = gfc_get_extern_function_decl (sym);
+
+ tmp = sym->backend_decl;
+
+ if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+ {
+ gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+ }
+
+ select_class_proc (se, expr->value.function.class_esym,
+ tmp, expr);
+ return;
+ }
+
+ if (gfc_is_proc_ptr_comp (expr, NULL))
+ tmp = get_proc_ptr_comp (expr);
+ else if (sym->attr.dummy)
{
tmp = gfc_get_symbol_decl (sym);
if (sym->attr.proc_pointer)
- tmp = build_fold_indirect_ref (tmp);
+ tmp = build_fold_indirect_ref_loc (input_location,
+ tmp);
gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
&& TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
}
@@ -1519,7 +1692,7 @@ gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
{
gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
- tmp = build_fold_addr_expr (tmp);
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
}
}
se->expr = tmp;
@@ -1596,7 +1769,9 @@ gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
tree var;
type = gfc_typenode_for_spec (&sym->ts);
- type = gfc_get_nodesc_array_type (type, sym->as, packed);
+ type = gfc_get_nodesc_array_type (type, sym->as, packed,
+ !sym->attr.target && !sym->attr.pointer
+ && !sym->attr.proc_pointer);
var = gfc_create_var (type, "ifm");
gfc_add_modify (block, var, fold_convert (type, data));
@@ -1625,15 +1800,15 @@ gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
{
GFC_TYPE_ARRAY_LBOUND (type, n)
- = gfc_conv_descriptor_lbound (desc, dim);
+ = gfc_conv_descriptor_lbound_get (desc, dim);
GFC_TYPE_ARRAY_UBOUND (type, n)
- = gfc_conv_descriptor_ubound (desc, dim);
+ = gfc_conv_descriptor_ubound_get (desc, dim);
}
else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
{
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_ubound (desc, dim),
- gfc_conv_descriptor_lbound (desc, dim));
+ gfc_conv_descriptor_ubound_get (desc, dim),
+ gfc_conv_descriptor_lbound_get (desc, dim));
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
GFC_TYPE_ARRAY_LBOUND (type, n),
tmp);
@@ -1708,16 +1883,16 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
if (sym->ts.type == BT_CHARACTER)
{
/* Create a copy of the dummy argument's length. */
- new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
- sm->expr->ts.cl = new_sym->ts.cl;
+ new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
+ sm->expr->ts.u.cl = new_sym->ts.u.cl;
/* If the length is specified as "*", record the length that
the caller is passing. We should use the callee's length
in all other cases. */
- if (!new_sym->ts.cl->length && se)
+ if (!new_sym->ts.u.cl->length && se)
{
se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
- new_sym->ts.cl->backend_decl = se->string_length;
+ new_sym->ts.u.cl->backend_decl = se->string_length;
}
}
@@ -1735,7 +1910,8 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
tmp = build_pointer_type (tmp);
if (sym->attr.pointer)
- value = build_fold_indirect_ref (se->expr);
+ value = build_fold_indirect_ref_loc (input_location,
+ se->expr);
else
value = se->expr;
value = fold_convert (tmp, value);
@@ -1744,11 +1920,13 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
/* If the argument is a scalar, a pointer to an array or an allocatable,
dereference it. */
else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
- value = build_fold_indirect_ref (se->expr);
+ value = build_fold_indirect_ref_loc (input_location,
+ se->expr);
/* For character(*), use the actual argument's descriptor. */
- else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.cl->length)
- value = build_fold_indirect_ref (se->expr);
+ else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
+ value = build_fold_indirect_ref_loc (input_location,
+ se->expr);
/* If the argument is an array descriptor, use it to determine
information about the actual argument's shape. */
@@ -1756,7 +1934,8 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
{
/* Get the actual argument's descriptor. */
- desc = build_fold_indirect_ref (se->expr);
+ desc = build_fold_indirect_ref_loc (input_location,
+ se->expr);
/* Create the replacement variable. */
tmp = gfc_conv_descriptor_data_get (desc);
@@ -1790,9 +1969,9 @@ gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
for (sym = mapping->syms; sym; sym = sym->next)
if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
- && !sym->new_sym->n.sym->ts.cl->backend_decl)
+ && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
{
- expr = sym->new_sym->n.sym->ts.cl->length;
+ expr = sym->new_sym->n.sym->ts.u.cl->length;
gfc_apply_interface_mapping_to_expr (mapping, expr);
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, expr);
@@ -1801,7 +1980,7 @@ gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
gfc_add_block_to_block (pre, &se.pre);
gfc_add_block_to_block (post, &se.post);
- sym->new_sym->n.sym->ts.cl->backend_decl = se.expr;
+ sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
}
}
@@ -1888,12 +2067,12 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
case GFC_ISYM_LEN:
/* TODO figure out why this condition is necessary. */
if (sym->attr.function
- && (arg1->ts.cl->length == NULL
- || (arg1->ts.cl->length->expr_type != EXPR_CONSTANT
- && arg1->ts.cl->length->expr_type != EXPR_VARIABLE)))
+ && (arg1->ts.u.cl->length == NULL
+ || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
+ && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
return false;
- new_expr = gfc_copy_expr (arg1->ts.cl->length);
+ new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
break;
case GFC_ISYM_SIZE:
@@ -2006,11 +2185,11 @@ gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
{
- expr->value.function.esym->ts.cl->length
- = gfc_copy_expr (map_expr->symtree->n.sym->ts.cl->length);
+ expr->value.function.esym->ts.u.cl->length
+ = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
gfc_apply_interface_mapping_to_expr (mapping,
- expr->value.function.esym->ts.cl->length);
+ expr->value.function.esym->ts.u.cl->length);
}
}
@@ -2031,10 +2210,10 @@ gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
return;
/* Copying an expression does not copy its length, so do that here. */
- if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
+ if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
{
- expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
- gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
+ expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
+ gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
}
/* Apply the mapping to any references. */
@@ -2091,6 +2270,7 @@ gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
break;
case EXPR_COMPCALL:
+ case EXPR_PPC:
gcc_unreachable ();
break;
}
@@ -2118,8 +2298,8 @@ gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
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)
+gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
+ sym_intent intent, bool formal_ptr)
{
gfc_se lse;
gfc_se rse;
@@ -2132,8 +2312,10 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
tree tmp_index;
tree tmp;
tree base_type;
+ tree size;
stmtblock_t body;
int n;
+ int dimen;
gcc_assert (expr->expr_type == EXPR_VARIABLE);
@@ -2153,8 +2335,8 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
gfc_conv_ss_startstride (&loop);
/* Build an ss for the temporary. */
- if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
- gfc_conv_string_length (expr->ts.cl, expr, &parmse->pre);
+ if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
+ gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
base_type = gfc_typenode_for_spec (&expr->ts);
if (GFC_ARRAY_TYPE_P (base_type)
@@ -2166,7 +2348,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
loop.temp_ss->data.temp.type = base_type;
if (expr->ts.type == BT_CHARACTER)
- loop.temp_ss->string_length = expr->ts.cl->backend_decl;
+ loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
else
loop.temp_ss->string_length = NULL;
@@ -2262,9 +2444,10 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
outside the innermost loop, so the overall transfer could be
optimized further. */
info = &rse.ss->data.info;
+ dimen = info->dimen;
tmp_index = gfc_index_zero_node;
- for (n = info->dimen - 1; n > 0; n--)
+ for (n = dimen - 1; n > 0; n--)
{
tree tmp_str;
tmp = rse.loop->loopvar[n];
@@ -2290,11 +2473,12 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
rse.loop->loopvar[0], offset);
/* Now use the offset for the reference. */
- tmp = build_fold_indirect_ref (info->data);
+ tmp = build_fold_indirect_ref_loc (input_location,
+ info->data);
rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
if (expr->ts.type == BT_CHARACTER)
- rse.string_length = expr->ts.cl->backend_decl;
+ rse.string_length = expr->ts.u.cl->backend_decl;
gfc_conv_expr (&lse, expr);
@@ -2322,14 +2506,50 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
/* Pass the string length to the argument expression. */
if (expr->ts.type == BT_CHARACTER)
- parmse->string_length = expr->ts.cl->backend_decl;
+ parmse->string_length = expr->ts.u.cl->backend_decl;
+
+ /* Determine the offset for pointer formal arguments and set the
+ lbounds to one. */
+ if (formal_ptr)
+ {
+ size = gfc_index_one_node;
+ offset = gfc_index_zero_node;
+ for (n = 0; n < dimen; n++)
+ {
+ tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
+ gfc_rank_cst[n]);
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ gfc_conv_descriptor_ubound_set (&parmse->pre,
+ parmse->expr,
+ gfc_rank_cst[n],
+ tmp);
+ gfc_conv_descriptor_lbound_set (&parmse->pre,
+ parmse->expr,
+ gfc_rank_cst[n],
+ gfc_index_one_node);
+ size = gfc_evaluate_now (size, &parmse->pre);
+ offset = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ offset, size);
+ offset = gfc_evaluate_now (offset, &parmse->pre);
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ rse.loop->to[n], rse.loop->from[n]);
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ size = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ size, tmp);
+ }
+
+ gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
+ offset);
+ }
/* We want either the address for the data or the address of the descriptor,
depending on the mode of passing array arguments. */
if (g77)
parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
else
- parmse->expr = build_fold_addr_expr (parmse->expr);
+ parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
return;
}
@@ -2358,13 +2578,213 @@ conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
}
+/* Takes a derived type expression and returns the address of a temporary
+ class object of the 'declared' type. */
+static void
+gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
+ gfc_typespec class_ts)
+{
+ gfc_component *cmp;
+ gfc_symbol *vtab;
+ gfc_symbol *declared = class_ts.u.derived;
+ gfc_ss *ss;
+ tree ctree;
+ tree var;
+ tree tmp;
+
+ /* The derived type needs to be converted to a temporary
+ CLASS object. */
+ tmp = gfc_typenode_for_spec (&class_ts);
+ var = gfc_create_var (tmp, "class");
+
+ /* Set the vptr. */
+ cmp = gfc_find_component (declared, "$vptr", true, true);
+ ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+ var, cmp->backend_decl, NULL_TREE);
+
+ /* Remember the vtab corresponds to the derived type
+ not to the class declared type. */
+ vtab = gfc_find_derived_vtab (e->ts.u.derived);
+ gcc_assert (vtab);
+ tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+ gfc_add_modify (&parmse->pre, ctree,
+ fold_convert (TREE_TYPE (ctree), tmp));
+
+ /* Now set the data field. */
+ cmp = gfc_find_component (declared, "$data", true, true);
+ ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+ var, cmp->backend_decl, NULL_TREE);
+ ss = gfc_walk_expr (e);
+ if (ss == gfc_ss_terminator)
+ {
+ gfc_conv_expr_reference (parmse, e);
+ tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+ gfc_add_modify (&parmse->pre, ctree, tmp);
+ }
+ else
+ {
+ gfc_conv_expr (parmse, e);
+ gfc_add_modify (&parmse->pre, ctree, parmse->expr);
+ }
+
+ /* Pass the address of the class object. */
+ parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
+}
+
+
+/* The following routine generates code for the intrinsic
+ procedures from the ISO_C_BINDING module:
+ * C_LOC (function)
+ * C_FUNLOC (function)
+ * C_F_POINTER (subroutine)
+ * C_F_PROCPOINTER (subroutine)
+ * C_ASSOCIATED (function)
+ One exception which is not handled here is C_F_POINTER with non-scalar
+ arguments. Returns 1 if the call was replaced by inline code (else: 0). */
+
+static int
+conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
+ gfc_actual_arglist * arg)
+{
+ gfc_symbol *fsym;
+ gfc_ss *argss;
+
+ if (sym->intmod_sym_id == ISOCBINDING_LOC)
+ {
+ if (arg->expr->rank == 0)
+ gfc_conv_expr_reference (se, arg->expr);
+ else
+ {
+ int f;
+ /* This is really the actual arg because no formal arglist is
+ created for C_LOC. */
+ fsym = arg->expr->symtree->n.sym;
+
+ /* We should want it to do g77 calling convention. */
+ f = (fsym != NULL)
+ && !(fsym->attr.pointer || fsym->attr.allocatable)
+ && fsym->as->type != AS_ASSUMED_SHAPE;
+ f = f || !sym->attr.always_explicit;
+
+ argss = gfc_walk_expr (arg->expr);
+ gfc_conv_array_parameter (se, arg->expr, argss, f,
+ NULL, NULL, NULL);
+ }
+
+ /* TODO -- the following two lines shouldn't be necessary, but if
+ they're removed, a bug is exposed later in the code path.
+ This workaround was thus introduced, but will have to be
+ removed; please see PR 35150 for details about the issue. */
+ se->expr = convert (pvoid_type_node, se->expr);
+ se->expr = gfc_evaluate_now (se->expr, &se->pre);
+
+ return 1;
+ }
+ else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
+ {
+ arg->expr->ts.type = sym->ts.u.derived->ts.type;
+ arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
+ arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
+ gfc_conv_expr_reference (se, arg->expr);
+
+ return 1;
+ }
+ else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
+ && arg->next->expr->rank == 0)
+ || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
+ {
+ /* Convert c_f_pointer if fptr is a scalar
+ and convert c_f_procpointer. */
+ gfc_se cptrse;
+ gfc_se fptrse;
+
+ gfc_init_se (&cptrse, NULL);
+ gfc_conv_expr (&cptrse, arg->expr);
+ gfc_add_block_to_block (&se->pre, &cptrse.pre);
+ gfc_add_block_to_block (&se->post, &cptrse.post);
+
+ gfc_init_se (&fptrse, NULL);
+ if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
+ || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
+ fptrse.want_pointer = 1;
+
+ gfc_conv_expr (&fptrse, arg->next->expr);
+ gfc_add_block_to_block (&se->pre, &fptrse.pre);
+ gfc_add_block_to_block (&se->post, &fptrse.post);
+
+ if (arg->next->expr->symtree->n.sym->attr.proc_pointer
+ && arg->next->expr->symtree->n.sym->attr.dummy)
+ fptrse.expr = build_fold_indirect_ref_loc (input_location,
+ fptrse.expr);
+
+ se->expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (fptrse.expr),
+ fptrse.expr,
+ fold_convert (TREE_TYPE (fptrse.expr),
+ cptrse.expr));
+
+ return 1;
+ }
+ else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
+ {
+ gfc_se arg1se;
+ gfc_se arg2se;
+
+ /* Build the addr_expr for the first argument. The argument is
+ already an *address* so we don't need to set want_pointer in
+ the gfc_se. */
+ gfc_init_se (&arg1se, NULL);
+ gfc_conv_expr (&arg1se, arg->expr);
+ gfc_add_block_to_block (&se->pre, &arg1se.pre);
+ gfc_add_block_to_block (&se->post, &arg1se.post);
+
+ /* See if we were given two arguments. */
+ if (arg->next == NULL)
+ /* Only given one arg so generate a null and do a
+ not-equal comparison against the first arg. */
+ se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr,
+ fold_convert (TREE_TYPE (arg1se.expr),
+ null_pointer_node));
+ else
+ {
+ tree eq_expr;
+ tree not_null_expr;
+
+ /* Given two arguments so build the arg2se from second arg. */
+ gfc_init_se (&arg2se, NULL);
+ gfc_conv_expr (&arg2se, arg->next->expr);
+ gfc_add_block_to_block (&se->pre, &arg2se.pre);
+ gfc_add_block_to_block (&se->post, &arg2se.post);
+
+ /* Generate test to compare that the two args are equal. */
+ eq_expr = fold_build2 (EQ_EXPR, boolean_type_node,
+ arg1se.expr, arg2se.expr);
+ /* Generate test to ensure that the first arg is not null. */
+ not_null_expr = fold_build2 (NE_EXPR, boolean_type_node,
+ arg1se.expr, null_pointer_node);
+
+ /* Finally, the generated test must check that both arg1 is not
+ NULL and that it is equal to the second arg. */
+ se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
+ not_null_expr, eq_expr);
+ }
+
+ return 1;
+ }
+
+ /* Nothing was done. */
+ return 0;
+}
+
+
/* 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. */
+ Return nonzero, if the call has alternate specifiers.
+ 'expr' is only needed for procedure pointer components. */
int
-gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
- gfc_actual_arglist * arg, tree append_args)
+gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
+ gfc_actual_arglist * arg, gfc_expr * expr,
+ tree append_args)
{
gfc_interface_mapping mapping;
tree arglist;
@@ -2380,6 +2800,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
tree var;
tree len;
tree stringargs;
+ tree result = NULL;
gfc_formal_arglist *formal;
int has_alternate_specifier = 0;
bool need_interface_mapping;
@@ -2390,6 +2811,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
gfc_symbol *fsym;
stmtblock_t post;
enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
+ gfc_component *comp = NULL;
arglist = NULL_TREE;
retargs = NULL_TREE;
@@ -2398,139 +2820,29 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
len = NULL_TREE;
gfc_clear_ts (&ts);
- if (sym->from_intmod == INTMOD_ISO_C_BINDING)
- {
- if (sym->intmod_sym_id == ISOCBINDING_LOC)
- {
- if (arg->expr->rank == 0)
- gfc_conv_expr_reference (se, arg->expr);
- else
- {
- int f;
- /* This is really the actual arg because no formal arglist is
- created for C_LOC. */
- fsym = arg->expr->symtree->n.sym;
-
- /* We should want it to do g77 calling convention. */
- f = (fsym != NULL)
- && !(fsym->attr.pointer || fsym->attr.allocatable)
- && fsym->as->type != AS_ASSUMED_SHAPE;
- f = f || !sym->attr.always_explicit;
-
- argss = gfc_walk_expr (arg->expr);
- gfc_conv_array_parameter (se, arg->expr, argss, f, NULL, NULL);
- }
-
- /* TODO -- the following two lines shouldn't be necessary, but
- they're removed a bug is exposed later in the codepath.
- This is workaround was thus introduced, but will have to be
- removed; please see PR 35150 for details about the issue. */
- se->expr = convert (pvoid_type_node, se->expr);
- se->expr = gfc_evaluate_now (se->expr, &se->pre);
-
- return 0;
- }
- else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
- {
- arg->expr->ts.type = sym->ts.derived->ts.type;
- arg->expr->ts.f90_type = sym->ts.derived->ts.f90_type;
- arg->expr->ts.kind = sym->ts.derived->ts.kind;
- gfc_conv_expr_reference (se, arg->expr);
-
- return 0;
- }
- else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
- && arg->next->expr->rank == 0)
- || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
- {
- /* Convert c_f_pointer if fptr is a scalar
- and convert c_f_procpointer. */
- gfc_se cptrse;
- gfc_se fptrse;
-
- gfc_init_se (&cptrse, NULL);
- gfc_conv_expr (&cptrse, arg->expr);
- gfc_add_block_to_block (&se->pre, &cptrse.pre);
- gfc_add_block_to_block (&se->post, &cptrse.post);
-
- gfc_init_se (&fptrse, NULL);
- if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
- fptrse.want_pointer = 1;
-
- gfc_conv_expr (&fptrse, arg->next->expr);
- gfc_add_block_to_block (&se->pre, &fptrse.pre);
- gfc_add_block_to_block (&se->post, &fptrse.post);
+ if (sym->from_intmod == INTMOD_ISO_C_BINDING
+ && conv_isocbinding_procedure (se, sym, arg))
+ return 0;
- tmp = arg->next->expr->symtree->n.sym->backend_decl;
- se->expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp), fptrse.expr,
- fold_convert (TREE_TYPE (tmp), cptrse.expr));
+ gfc_is_proc_ptr_comp (expr, &comp);
- return 0;
- }
- else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
- {
- gfc_se arg1se;
- gfc_se arg2se;
-
- /* Build the addr_expr for the first argument. The argument is
- already an *address* so we don't need to set want_pointer in
- the gfc_se. */
- gfc_init_se (&arg1se, NULL);
- gfc_conv_expr (&arg1se, arg->expr);
- gfc_add_block_to_block (&se->pre, &arg1se.pre);
- gfc_add_block_to_block (&se->post, &arg1se.post);
-
- /* See if we were given two arguments. */
- if (arg->next == NULL)
- /* Only given one arg so generate a null and do a
- not-equal comparison against the first arg. */
- se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr,
- fold_convert (TREE_TYPE (arg1se.expr),
- null_pointer_node));
- else
- {
- tree eq_expr;
- tree not_null_expr;
-
- /* Given two arguments so build the arg2se from second arg. */
- gfc_init_se (&arg2se, NULL);
- gfc_conv_expr (&arg2se, arg->next->expr);
- gfc_add_block_to_block (&se->pre, &arg2se.pre);
- gfc_add_block_to_block (&se->post, &arg2se.post);
-
- /* Generate test to compare that the two args are equal. */
- eq_expr = fold_build2 (EQ_EXPR, boolean_type_node,
- arg1se.expr, arg2se.expr);
- /* Generate test to ensure that the first arg is not null. */
- not_null_expr = fold_build2 (NE_EXPR, boolean_type_node,
- arg1se.expr, null_pointer_node);
-
- /* Finally, the generated test must check that both arg1 is not
- NULL and that it is equal to the second arg. */
- se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
- not_null_expr, eq_expr);
- }
-
- return 0;
- }
- }
-
if (se->ss != NULL)
{
if (!sym->attr.elemental)
{
gcc_assert (se->ss->type == GFC_SS_FUNCTION);
- if (se->ss->useflags)
- {
- gcc_assert (gfc_return_by_reference (sym)
- && sym->result->attr.dimension);
- gcc_assert (se->loop != NULL);
-
- /* Access the previously obtained result. */
- gfc_conv_tmp_array_ref (se);
- gfc_advance_se_ss_chain (se);
- return 0;
- }
+ if (se->ss->useflags)
+ {
+ gcc_assert ((!comp && gfc_return_by_reference (sym)
+ && sym->result->attr.dimension)
+ || (comp && comp->attr.dimension));
+ gcc_assert (se->loop != NULL);
+
+ /* Access the previously obtained result. */
+ gfc_conv_tmp_array_ref (se);
+ gfc_advance_se_ss_chain (se);
+ return 0;
+ }
}
info = &se->ss->data.info;
}
@@ -2539,21 +2851,34 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
gfc_init_block (&post);
gfc_init_interface_mapping (&mapping);
- need_interface_mapping = ((sym->ts.type == BT_CHARACTER
- && sym->ts.cl->length
- && sym->ts.cl->length->expr_type
- != EXPR_CONSTANT)
- || sym->attr.dimension);
- formal = sym->formal;
+ if (!comp)
+ {
+ formal = sym->formal;
+ need_interface_mapping = sym->attr.dimension ||
+ (sym->ts.type == BT_CHARACTER
+ && sym->ts.u.cl->length
+ && sym->ts.u.cl->length->expr_type
+ != EXPR_CONSTANT);
+ }
+ else
+ {
+ formal = comp->formal;
+ need_interface_mapping = comp->attr.dimension ||
+ (comp->ts.type == BT_CHARACTER
+ && comp->ts.u.cl->length
+ && comp->ts.u.cl->length->expr_type
+ != EXPR_CONSTANT);
+ }
+
/* Evaluate the arguments. */
for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
{
e = arg->expr;
fsym = formal ? formal->sym : NULL;
parm_kind = MISSING;
+
if (e == NULL)
{
-
if (se->ignore_optional)
{
/* Some intrinsics have already been resolved to the correct
@@ -2562,23 +2887,31 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
}
else if (arg->label)
{
- has_alternate_specifier = 1;
- continue;
+ has_alternate_specifier = 1;
+ continue;
}
else
{
/* Pass a NULL pointer for an absent arg. */
gfc_init_se (&parmse, NULL);
parmse.expr = null_pointer_node;
- if (arg->missing_arg_type == BT_CHARACTER)
+ if (arg->missing_arg_type == BT_CHARACTER)
parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
}
}
+ else if (fsym && fsym->ts.type == BT_CLASS
+ && e->ts.type == BT_DERIVED)
+ {
+ /* The derived type needs to be converted to a temporary
+ CLASS object. */
+ gfc_init_se (&parmse, se);
+ gfc_conv_derived_to_class (&parmse, e, fsym->ts);
+ }
else if (se->ss && se->ss->useflags)
{
/* An elemental function inside a scalarized loop. */
- gfc_init_se (&parmse, se);
- gfc_conv_expr_reference (&parmse, e);
+ gfc_init_se (&parmse, se);
+ gfc_conv_expr_reference (&parmse, e);
parm_kind = ELEMENTAL;
}
else
@@ -2588,7 +2921,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
argss = gfc_walk_expr (e);
if (argss == gfc_ss_terminator)
- {
+ {
if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.cray_pointee
&& fsym && fsym->attr.flavor == FL_PROCEDURE)
@@ -2627,21 +2960,67 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
&& fsym && fsym->attr.target)
{
gfc_conv_expr (&parmse, e);
- parmse.expr = build_fold_addr_expr (parmse.expr);
+ 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
+ && e->symtree->n.sym->result->attr.proc_pointer)
+ {
+ /* Functions returning procedure pointers. */
+ gfc_conv_expr (&parmse, e);
+ if (fsym && fsym->attr.proc_pointer)
+ parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
}
else
{
gfc_conv_expr_reference (&parmse, e);
+
+ /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
+ allocated on entry, it must be deallocated. */
+ if (fsym && fsym->attr.allocatable
+ && fsym->attr.intent == INTENT_OUT)
+ {
+ stmtblock_t block;
+
+ gfc_init_block (&block);
+ tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
+ true, NULL);
+ gfc_add_expr_to_block (&block, tmp);
+ tmp = fold_build2 (MODIFY_EXPR, void_type_node,
+ parmse.expr, null_pointer_node);
+ gfc_add_expr_to_block (&block, tmp);
+
+ if (fsym->attr.optional
+ && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional)
+ {
+ tmp = fold_build3 (COND_EXPR, void_type_node,
+ gfc_conv_expr_present (e->symtree->n.sym),
+ gfc_finish_block (&block),
+ build_empty_stmt (input_location));
+ }
+ else
+ tmp = gfc_finish_block (&block);
+
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
+
if (fsym && e->expr_type != EXPR_NULL
&& ((fsym->attr.pointer
&& fsym->attr.flavor != FL_PROCEDURE)
- || fsym->attr.proc_pointer))
+ || (fsym->attr.proc_pointer
+ && !(e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.dummy))
+ || (e->expr_type == EXPR_VARIABLE
+ && gfc_is_proc_ptr_comp (e, NULL))
+ || fsym->attr.allocatable))
{
/* Scalar pointer dummy args require an extra level of
indirection. The null pointer already contains
this level of indirection. */
parm_kind = SCALAR_POINTER;
- parmse.expr = build_fold_addr_expr (parmse.expr);
+ parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
}
}
}
@@ -2653,11 +3032,14 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
ALLOCATABLE or assumed shape, we do not use g77's calling
convention, and pass the address of the array descriptor
instead. Otherwise we use g77's calling convention. */
- int f;
+ bool f;
f = (fsym != NULL)
&& !(fsym->attr.pointer || fsym->attr.allocatable)
&& fsym->as->type != AS_ASSUMED_SHAPE;
- f = f || !sym->attr.always_explicit;
+ if (comp)
+ f = f || !comp->attr.always_explicit;
+ else
+ f = f || !sym->attr.always_explicit;
if (e->expr_type == EXPR_VARIABLE
&& is_subref_array (e))
@@ -2666,24 +3048,26 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
is converted to a temporary, which is passed and then
written back after the procedure call. */
gfc_conv_subref_array_arg (&parmse, e, f,
- fsym ? fsym->attr.intent : INTENT_INOUT);
+ fsym ? fsym->attr.intent : INTENT_INOUT,
+ fsym && fsym->attr.pointer);
else
gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
- sym->name);
+ sym->name, NULL);
/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
allocated on entry, it must be deallocated. */
if (fsym && fsym->attr.allocatable
&& fsym->attr.intent == INTENT_OUT)
{
- tmp = build_fold_indirect_ref (parmse.expr);
+ tmp = build_fold_indirect_ref_loc (input_location,
+ parmse.expr);
tmp = gfc_trans_dealloc_allocated (tmp);
if (fsym->attr.optional
&& e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.optional)
tmp = fold_build3 (COND_EXPR, void_type_node,
gfc_conv_expr_present (e->symtree->n.sym),
- tmp, build_empty_stmt ());
+ tmp, build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->pre, tmp);
}
}
@@ -2697,9 +3081,23 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
if (e && (fsym == NULL || fsym->attr.optional))
{
/* If an optional argument is itself an optional dummy argument,
- check its presence and substitute a null if absent. */
+ check its presence and substitute a null if absent. This is
+ only needed when passing an array to an elemental procedure
+ as then array elements are accessed - or no NULL pointer is
+ allowed and a "1" or "0" should be passed if not present.
+ When passing a non-array-descriptor full array to a
+ non-array-descriptor dummy, no check is needed. For
+ 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. */
if (e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.optional)
+ && e->symtree->n.sym->attr.optional
+ && ((e->rank > 0 && sym->attr.elemental)
+ || e->representation.length || e->ts.type == BT_CHARACTER
+ || (e->rank > 0
+ && (fsym == NULL || fsym->as->type == AS_ASSUMED_SHAPE
+ || fsym->as->type == AS_DEFERRED))))
gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
e->representation.length);
}
@@ -2712,11 +3110,11 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
&& parmse.string_length == NULL_TREE
&& e->ts.type == BT_PROCEDURE
&& e->symtree->n.sym->ts.type == BT_CHARACTER
- && e->symtree->n.sym->ts.cl->length != NULL
- && e->symtree->n.sym->ts.cl->length->expr_type == EXPR_CONSTANT)
+ && e->symtree->n.sym->ts.u.cl->length != NULL
+ && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
{
- gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
- parmse.string_length = e->symtree->n.sym->ts.cl->backend_decl;
+ gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
+ parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
}
}
@@ -2730,12 +3128,13 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
deallocated for non-variable scalars. Non-variable arrays are
dealt with in trans-array.c(gfc_conv_array_parameter). */
if (e && e->ts.type == BT_DERIVED
- && e->ts.derived->attr.alloc_comp
+ && e->ts.u.derived->attr.alloc_comp
&& !(e->symtree && e->symtree->n.sym->attr.pointer)
&& (e->expr_type != EXPR_VARIABLE && !e->rank))
{
int parm_rank;
- tmp = build_fold_indirect_ref (parmse.expr);
+ tmp = build_fold_indirect_ref_loc (input_location,
+ parmse.expr);
parm_rank = e->rank;
switch (parm_kind)
{
@@ -2745,7 +3144,8 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
break;
case (SCALAR_POINTER):
- tmp = build_fold_indirect_ref (tmp);
+ tmp = build_fold_indirect_ref_loc (input_location,
+ tmp);
break;
}
@@ -2755,15 +3155,106 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
{
tree local_tmp;
local_tmp = gfc_evaluate_now (tmp, &se->pre);
- local_tmp = gfc_copy_alloc_comp (e->ts.derived, local_tmp, tmp, parm_rank);
+ local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
gfc_add_expr_to_block (&se->post, local_tmp);
}
- tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
+ tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
gfc_add_expr_to_block (&se->post, tmp);
}
+ /* Add argument checking of passing an unallocated/NULL actual to
+ a nonallocatable/nonpointer dummy. */
+
+ if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
+ {
+ symbol_attribute *attr;
+ char *msg;
+ tree cond;
+
+ if (e->expr_type == EXPR_VARIABLE)
+ attr = &e->symtree->n.sym->attr;
+ else if (e->expr_type == EXPR_FUNCTION)
+ {
+ /* For intrinsic functions, the gfc_attr are not available. */
+ if (e->symtree->n.sym->attr.generic && e->value.function.isym)
+ goto end_pointer_check;
+
+ if (e->symtree->n.sym->attr.generic)
+ attr = &e->value.function.esym->attr;
+ else
+ attr = &e->symtree->n.sym->result->attr;
+ }
+ else
+ goto end_pointer_check;
+
+ if (attr->optional)
+ {
+ /* If the actual argument is an optional pointer/allocatable and
+ the formal argument takes an nonpointer optional value,
+ it is invalid to pass a non-present argument on, even
+ though there is no technical reason for this in gfortran.
+ See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
+ tree present, nullptr, type;
+
+ if (attr->allocatable
+ && (fsym == NULL || !fsym->attr.allocatable))
+ asprintf (&msg, "Allocatable actual argument '%s' is not "
+ "allocated or not present", e->symtree->n.sym->name);
+ else if (attr->pointer
+ && (fsym == NULL || !fsym->attr.pointer))
+ asprintf (&msg, "Pointer actual argument '%s' is not "
+ "associated or not present",
+ e->symtree->n.sym->name);
+ else if (attr->proc_pointer
+ && (fsym == NULL || !fsym->attr.proc_pointer))
+ asprintf (&msg, "Proc-pointer actual argument '%s' is not "
+ "associated or not present",
+ e->symtree->n.sym->name);
+ else
+ goto end_pointer_check;
+
+ present = gfc_conv_expr_present (e->symtree->n.sym);
+ type = TREE_TYPE (present);
+ present = fold_build2 (EQ_EXPR, boolean_type_node, present,
+ fold_convert (type, null_pointer_node));
+ type = TREE_TYPE (parmse.expr);
+ nullptr = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
+ fold_convert (type, null_pointer_node));
+ cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node,
+ present, nullptr);
+ }
+ else
+ {
+ if (attr->allocatable
+ && (fsym == NULL || !fsym->attr.allocatable))
+ asprintf (&msg, "Allocatable actual argument '%s' is not "
+ "allocated", e->symtree->n.sym->name);
+ else if (attr->pointer
+ && (fsym == NULL || !fsym->attr.pointer))
+ asprintf (&msg, "Pointer actual argument '%s' is not "
+ "associated", e->symtree->n.sym->name);
+ else if (attr->proc_pointer
+ && (fsym == NULL || !fsym->attr.proc_pointer))
+ asprintf (&msg, "Proc-pointer actual argument '%s' is not "
+ "associated", e->symtree->n.sym->name);
+ else
+ goto end_pointer_check;
+
+
+ cond = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr,
+ fold_convert (TREE_TYPE (parmse.expr),
+ null_pointer_node));
+ }
+
+ gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
+ msg);
+ gfc_free (msg);
+ }
+ end_pointer_check:
+
+
/* Character strings are passed as two parameters, a length and a
pointer - except for Bind(c) which only passes the pointer. */
if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
@@ -2773,12 +3264,16 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
}
gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
- ts = sym->ts;
+ if (comp)
+ ts = comp->ts;
+ else
+ ts = sym->ts;
+
if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
se->string_length = build_int_cst (gfc_charlen_type_node, 1);
else if (ts.type == BT_CHARACTER)
{
- if (sym->ts.cl->length == NULL)
+ if (ts.u.cl->length == NULL)
{
/* Assumed character length results are not allowed by 5.1.1.5 of the
standard and are trapped in resolve.c; except in the case of SPREAD
@@ -2793,19 +3288,19 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
formal = sym->ns->proc_name->formal;
for (; formal; formal = formal->next)
if (strcmp (formal->sym->name, sym->name) == 0)
- cl.backend_decl = formal->sym->ts.cl->backend_decl;
+ cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
}
}
- else
+ else
{
tree tmp;
/* Calculate the length of the returned string. */
gfc_init_se (&parmse, NULL);
if (need_interface_mapping)
- gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
+ gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
else
- gfc_conv_expr (&parmse, sym->ts.cl->length);
+ 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);
@@ -2818,12 +3313,13 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
/* Set up a charlen structure for it. */
cl.next = NULL;
cl.length = NULL;
- ts.cl = &cl;
+ ts.u.cl = &cl;
len = cl.backend_decl;
}
- byref = gfc_return_by_reference (sym);
+ byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
+ || (!comp && gfc_return_by_reference (sym));
if (byref)
{
if (se->direct_byref)
@@ -2834,11 +3330,38 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
&& TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
&& GFC_DESCRIPTOR_TYPE_P
(TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
- se->expr = build_fold_indirect_ref (se->expr);
+ se->expr = build_fold_indirect_ref_loc (input_location,
+ se->expr);
+ result = build_fold_indirect_ref_loc (input_location,
+ se->expr);
retargs = gfc_chainon_list (retargs, se->expr);
}
- else if (sym->result->attr.dimension)
+ else if (comp && comp->attr.dimension)
+ {
+ gcc_assert (se->loop && info);
+
+ /* Set the type of the array. */
+ tmp = gfc_typenode_for_spec (&comp->ts);
+ info->dimen = se->loop->dimen;
+
+ /* Evaluate the bounds of the result, if known. */
+ gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
+
+ /* Create a temporary to store the result. In case the function
+ returns a pointer, the temporary will be a shallow copy and
+ mustn't be deallocated. */
+ callee_alloc = comp->attr.allocatable || comp->attr.pointer;
+ gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
+ NULL_TREE, false, !comp->attr.pointer,
+ callee_alloc, &se->ss->expr->where);
+
+ /* Pass the temporary as the first argument. */
+ result = info->descriptor;
+ tmp = gfc_build_addr_expr (NULL_TREE, result);
+ retargs = gfc_chainon_list (retargs, tmp);
+ }
+ else if (!comp && sym->result->attr.dimension)
{
gcc_assert (se->loop && info);
@@ -2858,24 +3381,31 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
callee_alloc, &se->ss->expr->where);
/* Pass the temporary as the first argument. */
- tmp = info->descriptor;
- tmp = build_fold_addr_expr (tmp);
+ result = info->descriptor;
+ tmp = gfc_build_addr_expr (NULL_TREE, result);
retargs = gfc_chainon_list (retargs, tmp);
}
else if (ts.type == BT_CHARACTER)
{
/* Pass the string length. */
- type = gfc_get_character_type (ts.kind, ts.cl);
+ type = gfc_get_character_type (ts.kind, ts.u.cl);
type = build_pointer_type (type);
/* Return an address to a char[0:len-1]* temporary for
character pointers. */
- if (sym->attr.pointer || sym->attr.allocatable)
+ if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
+ || (comp && (comp->attr.pointer || comp->attr.allocatable)))
{
var = gfc_create_var (type, "pstr");
+ if ((!comp && sym->attr.allocatable)
+ || (comp && comp->attr.allocatable))
+ gfc_add_modify (&se->pre, var,
+ fold_convert (TREE_TYPE (var),
+ null_pointer_node));
+
/* Provide an address expression for the function arguments. */
- var = build_fold_addr_expr (var);
+ var = gfc_build_addr_expr (NULL_TREE, var);
}
else
var = gfc_conv_string_tmp (se, type, len);
@@ -2887,7 +3417,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
type = gfc_get_complex_type (ts.kind);
- var = build_fold_addr_expr (gfc_create_var (type, "cmplx"));
+ var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
retargs = gfc_chainon_list (retargs, var);
}
@@ -2909,7 +3439,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
arglist = chainon (arglist, append_args);
/* Generate the actual call. */
- gfc_conv_function_val (se, sym);
+ conv_function_val (se, sym, expr);
/* If there are alternate return labels, function type should be
integer. Can't modify the type in place though, since it can be shared
@@ -2923,7 +3453,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
TREE_TYPE (sym->backend_decl)
= build_function_type (integer_type_node,
TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
- se->expr = build_fold_addr_expr (sym->backend_decl);
+ se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
}
else
TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
@@ -2936,8 +3466,11 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
something like
x = f()
where f is pointer valued, we have to dereference the result. */
- if (!se->want_pointer && !byref && sym->attr.pointer)
- se->expr = build_fold_indirect_ref (se->expr);
+ if (!se->want_pointer && !byref
+ && (sym->attr.pointer || sym->attr.allocatable)
+ && !gfc_is_proc_ptr_comp (expr, NULL))
+ se->expr = build_fold_indirect_ref_loc (input_location,
+ se->expr);
/* f2c calling conventions require a scalar default real function to
return a double precision result. Convert this back to default
@@ -2964,9 +3497,9 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
if (!se->direct_byref)
{
- if (sym->attr.dimension)
+ if (sym->attr.dimension || (comp && comp->attr.dimension))
{
- if (flag_bounds_check)
+ if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
{
/* Check the data pointer hasn't been modified. This would
happen in a function returning a pointer. */
@@ -2980,11 +3513,12 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
/* Bundle in the string length. */
se->string_length = len;
}
- else if (sym->ts.type == BT_CHARACTER)
+ else if (ts.type == BT_CHARACTER)
{
/* Dereference for character pointer results. */
- if (sym->attr.pointer || sym->attr.allocatable)
- se->expr = build_fold_indirect_ref (var);
+ if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
+ || (comp && (comp->attr.pointer || comp->attr.allocatable)))
+ se->expr = build_fold_indirect_ref_loc (input_location, var);
else
se->expr = var;
@@ -2992,15 +3526,44 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
}
else
{
- gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
- se->expr = build_fold_indirect_ref (var);
+ gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
+ se->expr = build_fold_indirect_ref_loc (input_location, var);
}
}
}
/* Follow the function call with the argument post block. */
if (byref)
- gfc_add_block_to_block (&se->pre, &post);
+ {
+ gfc_add_block_to_block (&se->pre, &post);
+
+ /* Transformational functions of derived types with allocatable
+ components must have the result allocatable components copied. */
+ arg = expr->value.function.actual;
+ if (result && arg && expr->rank
+ && expr->value.function.isym
+ && expr->value.function.isym->transformational
+ && arg->expr->ts.type == BT_DERIVED
+ && arg->expr->ts.u.derived->attr.alloc_comp)
+ {
+ tree tmp2;
+ /* Copy the allocatable components. We have to use a
+ temporary here to prevent source allocatable components
+ from being corrupted. */
+ tmp2 = gfc_evaluate_now (result, &se->pre);
+ tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
+ result, tmp2, expr->rank);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
+ expr->rank);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ /* Finally free the temporary's data field. */
+ tmp = gfc_conv_descriptor_data_get (tmp2);
+ tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
+ }
else
gfc_add_block_to_block (&se->post, &post);
@@ -3018,7 +3581,8 @@ fill_with_spaces (tree start, tree type, tree size)
/* For a simple char type, we can call memset(). */
if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
- return build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3, start,
+ return build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_MEMSET], 3, start,
build_int_cst (gfc_get_int_type (gfc_c_int_kind),
lang_hooks.to_target_charset (' ')),
size);
@@ -3045,7 +3609,8 @@ fill_with_spaces (tree start, tree type, tree size)
cond = fold_build2 (LE_EXPR, boolean_type_node, i,
fold_convert (sizetype, integer_zero_node));
tmp = build1_v (GOTO_EXPR, exit_label);
- tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
+ tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
+ build_empty_stmt (input_location));
gfc_add_expr_to_block (&loop, tmp);
/* Assignment. */
@@ -3178,11 +3743,13 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
/* Truncate string if source is too long. */
cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
- tmp2 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
+ tmp2 = build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_MEMMOVE],
3, dest, src, dlen);
/* Else copy and pad with spaces. */
- tmp3 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
+ tmp3 = build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_MEMMOVE],
3, dest, src, slen);
tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest,
@@ -3198,7 +3765,8 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
/* The whole copy_string function is there. */
tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
- tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
+ tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
+ build_empty_stmt (input_location));
gfc_add_expr_to_block (block, tmp);
}
@@ -3250,8 +3818,8 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
/* Copy string arguments. */
tree arglen;
- gcc_assert (fsym->ts.cl && fsym->ts.cl->length
- && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
+ gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
+ && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
tmp = gfc_build_addr_expr (build_pointer_type (type),
@@ -3288,22 +3856,22 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
if (sym->ts.type == BT_CHARACTER)
{
- gfc_conv_const_charlen (sym->ts.cl);
+ gfc_conv_const_charlen (sym->ts.u.cl);
/* Force the expression to the correct length. */
if (!INTEGER_CST_P (se->string_length)
|| tree_int_cst_lt (se->string_length,
- sym->ts.cl->backend_decl))
+ sym->ts.u.cl->backend_decl))
{
- type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
+ type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
tmp = gfc_create_var (type, sym->name);
tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
- gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
+ gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
sym->ts.kind, se->string_length, se->expr,
sym->ts.kind);
se->expr = tmp;
}
- se->string_length = sym->ts.cl->backend_decl;
+ se->string_length = sym->ts.u.cl->backend_decl;
}
/* Restore the original variables. */
@@ -3339,7 +3907,46 @@ gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
sym = expr->value.function.esym;
if (!sym)
sym = expr->symtree->n.sym;
- gfc_conv_function_call (se, sym, expr->value.function.actual, NULL_TREE);
+
+ gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
+ NULL_TREE);
+}
+
+
+/* Determine whether the given EXPR_CONSTANT is a zero initializer. */
+
+static bool
+is_zero_initializer_p (gfc_expr * expr)
+{
+ if (expr->expr_type != EXPR_CONSTANT)
+ return false;
+
+ /* We ignore constants with prescribed memory representations for now. */
+ if (expr->representation.string)
+ return false;
+
+ switch (expr->ts.type)
+ {
+ case BT_INTEGER:
+ return mpz_cmp_si (expr->value.integer, 0) == 0;
+
+ case BT_REAL:
+ return mpfr_zero_p (expr->value.real)
+ && MPFR_SIGN (expr->value.real) >= 0;
+
+ case BT_LOGICAL:
+ return expr->value.logical == 0;
+
+ case BT_COMPLEX:
+ return mpfr_zero_p (mpc_realref (expr->value.complex))
+ && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
+ && mpfr_zero_p (mpc_imagref (expr->value.complex))
+ && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
+
+ default:
+ break;
+ }
+ return false;
}
@@ -3372,9 +3979,9 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
used as initialization expressions). If so, we need to modify
the 'expr' to be that for a (void *). */
if (expr != NULL && expr->ts.type == BT_DERIVED
- && expr->ts.is_iso_c && expr->ts.derived)
+ && expr->ts.is_iso_c && expr->ts.u.derived)
{
- gfc_symbol *derived = expr->ts.derived;
+ gfc_symbol *derived = expr->ts.u.derived;
expr = gfc_int_expr (0);
@@ -3382,6 +3989,10 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
its kind. */
expr->ts.f90_type = derived->ts.f90_type;
expr->ts.kind = derived->ts.kind;
+
+ gfc_init_se (&se, NULL);
+ gfc_conv_constant (&se, expr);
+ return se.expr;
}
if (array)
@@ -3389,6 +4000,9 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
/* Arrays need special handling. */
if (pointer)
return gfc_build_null_descriptor (type);
+ /* Special case assigning an array to zero. */
+ else if (is_zero_initializer_p (expr))
+ return build_constructor (type, NULL);
else
return gfc_conv_array_initializer (type, expr);
}
@@ -3399,12 +4013,13 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
switch (ts->type)
{
case BT_DERIVED:
+ case BT_CLASS:
gfc_init_se (&se, NULL);
gfc_conv_structure (&se, expr, 1);
return se.expr;
case BT_CHARACTER:
- return gfc_conv_string_init (ts->cl->backend_decl,expr);
+ return gfc_conv_string_init (ts->u.cl->backend_decl,expr);
default:
gfc_init_se (&se, NULL);
@@ -3492,7 +4107,7 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
gfc_conv_tmp_array_ref (&lse);
if (cm->ts.type == BT_CHARACTER)
- lse.string_length = cm->ts.cl->backend_decl;
+ lse.string_length = cm->ts.u.cl->backend_decl;
gfc_conv_expr (&rse, expr);
@@ -3518,6 +4133,149 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
}
+static tree
+gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
+ gfc_expr * expr)
+{
+ gfc_se se;
+ gfc_ss *rss;
+ stmtblock_t block;
+ tree offset;
+ int n;
+ tree tmp;
+ tree tmp2;
+ gfc_array_spec *as;
+ gfc_expr *arg = NULL;
+
+ gfc_start_block (&block);
+ gfc_init_se (&se, NULL);
+
+ /* Get the descriptor for the expressions. */
+ rss = gfc_walk_expr (expr);
+ se.want_pointer = 0;
+ gfc_conv_expr_descriptor (&se, expr, rss);
+ gfc_add_block_to_block (&block, &se.pre);
+ gfc_add_modify (&block, dest, se.expr);
+
+ /* Deal with arrays of derived types with allocatable components. */
+ if (cm->ts.type == BT_DERIVED
+ && cm->ts.u.derived->attr.alloc_comp)
+ tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
+ se.expr, dest,
+ cm->as->rank);
+ else
+ tmp = gfc_duplicate_allocatable (dest, se.expr,
+ TREE_TYPE(cm->backend_decl),
+ cm->as->rank);
+
+ gfc_add_expr_to_block (&block, tmp);
+ gfc_add_block_to_block (&block, &se.post);
+
+ if (expr->expr_type != EXPR_VARIABLE)
+ gfc_conv_descriptor_data_set (&block, se.expr,
+ null_pointer_node);
+
+ /* We need to know if the argument of a conversion function is a
+ variable, so that the correct lower bound can be used. */
+ if (expr->expr_type == EXPR_FUNCTION
+ && expr->value.function.isym
+ && expr->value.function.isym->conversion
+ && expr->value.function.actual->expr
+ && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
+ arg = expr->value.function.actual->expr;
+
+ /* Obtain the array spec of full array references. */
+ if (arg)
+ as = gfc_get_full_arrayspec_from_expr (arg);
+ else
+ as = gfc_get_full_arrayspec_from_expr (expr);
+
+ /* Shift the lbound and ubound of temporaries to being unity,
+ rather than zero, based. Always calculate the offset. */
+ offset = gfc_conv_descriptor_offset_get (dest);
+ gfc_add_modify (&block, offset, gfc_index_zero_node);
+ tmp2 =gfc_create_var (gfc_array_index_type, NULL);
+
+ for (n = 0; n < expr->rank; n++)
+ {
+ tree span;
+ tree lbound;
+
+ /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
+ TODO It looks as if gfc_conv_expr_descriptor should return
+ the correct bounds and that the following should not be
+ necessary. This would simplify gfc_conv_intrinsic_bound
+ as well. */
+ if (as && as->lower[n])
+ {
+ gfc_se lbse;
+ gfc_init_se (&lbse, NULL);
+ gfc_conv_expr (&lbse, as->lower[n]);
+ gfc_add_block_to_block (&block, &lbse.pre);
+ lbound = gfc_evaluate_now (lbse.expr, &block);
+ }
+ else if (as && arg)
+ {
+ tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
+ lbound = gfc_conv_descriptor_lbound_get (tmp,
+ gfc_rank_cst[n]);
+ }
+ else if (as)
+ lbound = gfc_conv_descriptor_lbound_get (dest,
+ gfc_rank_cst[n]);
+ else
+ lbound = gfc_index_one_node;
+
+ lbound = fold_convert (gfc_array_index_type, lbound);
+
+ /* Shift the bounds and set the offset accordingly. */
+ tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
+ span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
+ gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, span, lbound);
+ gfc_conv_descriptor_ubound_set (&block, dest,
+ gfc_rank_cst[n], tmp);
+ gfc_conv_descriptor_lbound_set (&block, dest,
+ gfc_rank_cst[n], lbound);
+
+ tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_lbound_get (dest,
+ gfc_rank_cst[n]),
+ gfc_conv_descriptor_stride_get (dest,
+ gfc_rank_cst[n]));
+ gfc_add_modify (&block, tmp2, tmp);
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
+ gfc_conv_descriptor_offset_set (&block, dest, tmp);
+ }
+
+ if (arg)
+ {
+ /* If a conversion expression has a null data pointer
+ argument, nullify the allocatable component. */
+ tree non_null_expr;
+ tree null_expr;
+
+ if (arg->symtree->n.sym->attr.allocatable
+ || arg->symtree->n.sym->attr.pointer)
+ {
+ non_null_expr = gfc_finish_block (&block);
+ gfc_start_block (&block);
+ gfc_conv_descriptor_data_set (&block, dest,
+ null_pointer_node);
+ null_expr = gfc_finish_block (&block);
+ tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
+ tmp = build2 (EQ_EXPR, boolean_type_node, tmp,
+ fold_convert (TREE_TYPE (tmp),
+ null_pointer_node));
+ return build3_v (COND_EXPR, tmp,
+ null_expr, non_null_expr);
+ }
+ }
+
+ return gfc_finish_block (&block);
+}
+
+
/* Assign a single component of a derived type constructor. */
static tree
@@ -3528,8 +4286,6 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
gfc_ss *rss;
stmtblock_t block;
tree tmp;
- tree offset;
- int n;
gfc_start_block (&block);
@@ -3563,97 +4319,21 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
gfc_add_block_to_block (&block, &se.post);
}
}
+ else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
+ {
+ /* NULL initialization for CLASS components. */
+ tmp = gfc_trans_structure_assign (dest,
+ gfc_default_initializer (&cm->ts));
+ gfc_add_expr_to_block (&block, tmp);
+ }
else if (cm->attr.dimension)
{
if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
else if (cm->attr.allocatable)
{
- tree tmp2;
-
- gfc_init_se (&se, NULL);
-
- rss = gfc_walk_expr (expr);
- se.want_pointer = 0;
- gfc_conv_expr_descriptor (&se, expr, rss);
- gfc_add_block_to_block (&block, &se.pre);
-
- tmp = fold_convert (TREE_TYPE (dest), se.expr);
- gfc_add_modify (&block, dest, tmp);
-
- if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
- tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest,
- cm->as->rank);
- else
- tmp = gfc_duplicate_allocatable (dest, se.expr,
- TREE_TYPE(cm->backend_decl),
- cm->as->rank);
-
+ tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
gfc_add_expr_to_block (&block, tmp);
- gfc_add_block_to_block (&block, &se.post);
-
- if (expr->expr_type != EXPR_VARIABLE)
- gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
-
- /* Shift the lbound and ubound of temporaries to being unity, rather
- than zero, based. Calculate the offset for all cases. */
- offset = gfc_conv_descriptor_offset (dest);
- gfc_add_modify (&block, offset, gfc_index_zero_node);
- tmp2 =gfc_create_var (gfc_array_index_type, NULL);
- for (n = 0; n < expr->rank; n++)
- {
- if (expr->expr_type != EXPR_VARIABLE
- && expr->expr_type != EXPR_CONSTANT)
- {
- tree span;
- tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
- span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
- gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]));
- gfc_add_modify (&block, tmp,
- fold_build2 (PLUS_EXPR,
- gfc_array_index_type,
- span, gfc_index_one_node));
- tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
- gfc_add_modify (&block, tmp, gfc_index_one_node);
- }
- tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_lbound (dest,
- gfc_rank_cst[n]),
- gfc_conv_descriptor_stride (dest,
- gfc_rank_cst[n]));
- gfc_add_modify (&block, tmp2, tmp);
- tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
- gfc_add_modify (&block, offset, tmp);
- }
-
- if (expr->expr_type == EXPR_FUNCTION
- && expr->value.function.isym
- && expr->value.function.isym->conversion
- && expr->value.function.actual->expr
- && expr->value.function.actual->expr->expr_type
- == EXPR_VARIABLE)
- {
- /* If a conversion expression has a null data pointer
- argument, nullify the allocatable component. */
- gfc_symbol *s;
- tree non_null_expr;
- tree null_expr;
- s = expr->value.function.actual->expr->symtree->n.sym;
- if (s->attr.allocatable || s->attr.pointer)
- {
- non_null_expr = gfc_finish_block (&block);
- gfc_start_block (&block);
- gfc_conv_descriptor_data_set (&block, dest,
- null_pointer_node);
- null_expr = gfc_finish_block (&block);
- tmp = gfc_conv_descriptor_data_get (s->backend_decl);
- tmp = build2 (EQ_EXPR, boolean_type_node, tmp,
- fold_convert (TREE_TYPE (tmp),
- null_pointer_node));
- return build3_v (COND_EXPR, tmp, null_expr,
- non_null_expr);
- }
- }
}
else
{
@@ -3687,7 +4367,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
gfc_conv_expr (&se, expr);
if (cm->ts.type == BT_CHARACTER)
- lse.string_length = cm->ts.cl->backend_decl;
+ lse.string_length = cm->ts.u.cl->backend_decl;
lse.expr = dest;
tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
gfc_add_expr_to_block (&block, tmp);
@@ -3707,13 +4387,26 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr)
tree tmp;
gfc_start_block (&block);
- cm = expr->ts.derived->components;
+ cm = expr->ts.u.derived->components;
for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
{
/* Skip absent members in default initializers. */
if (!c->expr)
continue;
+ /* Handle c_null_(fun)ptr. */
+ if (c && c->expr && c->expr->ts.is_iso_c)
+ {
+ field = cm->backend_decl;
+ tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
+ dest, field, NULL_TREE);
+ tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp), tmp,
+ fold_convert (TREE_TYPE (tmp),
+ null_pointer_node));
+ gfc_add_expr_to_block (&block, tmp);
+ continue;
+ }
+
field = cm->backend_decl;
tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
dest, field, NULL_TREE);
@@ -3743,13 +4436,13 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
if (!init)
{
/* Create a temporary variable and fill it in. */
- se->expr = gfc_create_var (type, expr->ts.derived->name);
+ se->expr = gfc_create_var (type, expr->ts.u.derived->name);
tmp = gfc_trans_structure_assign (se->expr, expr);
gfc_add_expr_to_block (&se->pre, tmp);
return;
}
- cm = expr->ts.derived->components;
+ cm = expr->ts.u.derived->components;
for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
{
@@ -3760,11 +4453,41 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
if (!c->expr || cm->attr.allocatable)
continue;
- val = gfc_conv_initializer (c->expr, &cm->ts,
- TREE_TYPE (cm->backend_decl), cm->attr.dimension, cm->attr.pointer);
+ if (cm->ts.type == BT_CLASS)
+ {
+ gfc_component *data;
+ data = gfc_find_component (cm->ts.u.derived, "$data", true, true);
+ if (!data->backend_decl)
+ gfc_get_derived_type (cm->ts.u.derived);
+ val = gfc_conv_initializer (c->expr, &cm->ts,
+ TREE_TYPE (data->backend_decl),
+ data->attr.dimension,
+ data->attr.pointer);
+
+ CONSTRUCTOR_APPEND_ELT (v, data->backend_decl, val);
+ }
+ else if (strcmp (cm->name, "$size") == 0)
+ {
+ val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
+ CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
+ }
+ else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
+ && strcmp (cm->name, "$extends") == 0)
+ {
+ gfc_symbol *vtabs;
+ vtabs = cm->initializer->symtree->n.sym;
+ val = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
+ CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
+ }
+ else
+ {
+ val = gfc_conv_initializer (c->expr, &cm->ts,
+ TREE_TYPE (cm->backend_decl), cm->attr.dimension,
+ cm->attr.pointer || cm->attr.proc_pointer);
- /* Append it to the constructor list. */
- CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
+ /* Append it to the constructor list. */
+ CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
+ }
}
se->expr = build_constructor (type, v);
if (init)
@@ -3808,6 +4531,8 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
/* Substitute a scalar expression evaluated outside the scalarization
loop. */
se->expr = se->ss->data.scalar.expr;
+ if (se->ss->type == GFC_SS_REFERENCE)
+ se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
se->string_length = se->ss->string_length;
gfc_advance_se_ss_chain (se);
return;
@@ -3818,8 +4543,8 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
null_pointer_node. C_PTR and C_FUNPTR are converted to match the
typespec for the C_PTR and C_FUNPTR symbols, which has already been
updated to be an integer with a kind equal to the size of a (void *). */
- if (expr->ts.type == BT_DERIVED && expr->ts.derived
- && expr->ts.derived->attr.is_iso_c)
+ if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
+ && expr->ts.u.derived->attr.is_iso_c)
{
if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
|| expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
@@ -3832,9 +4557,9 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
{
/* Update the type/kind of the expression to be what the new
type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
- expr->ts.type = expr->ts.derived->ts.type;
- expr->ts.f90_type = expr->ts.derived->ts.f90_type;
- expr->ts.kind = expr->ts.derived->ts.kind;
+ expr->ts.type = expr->ts.u.derived->ts.type;
+ expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
+ expr->ts.kind = expr->ts.u.derived->ts.kind;
}
}
@@ -3928,9 +4653,9 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
if (se->ss && se->ss->expr == expr
&& se->ss->type == GFC_SS_REFERENCE)
{
- se->expr = se->ss->data.scalar.expr;
- se->string_length = se->ss->string_length;
- gfc_advance_se_ss_chain (se);
+ /* Returns a reference to the scalar evaluated outside the loop
+ for this case. */
+ gfc_conv_expr (se, expr);
return;
}
@@ -3979,7 +4704,8 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
{
tree tmp = se->expr;
STRIP_TYPE_NOPS (tmp);
- var = build_decl (CONST_DECL, NULL, TREE_TYPE (tmp));
+ var = build_decl (input_location,
+ CONST_DECL, NULL, TREE_TYPE (tmp));
DECL_INITIAL (var) = tmp;
TREE_STATIC (var) = 1;
pushdecl (var);
@@ -3992,14 +4718,14 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
gfc_add_block_to_block (&se->pre, &se->post);
/* Take the address of that value. */
- se->expr = build_fold_addr_expr (var);
+ se->expr = gfc_build_addr_expr (NULL_TREE, var);
}
tree
gfc_trans_pointer_assign (gfc_code * code)
{
- return gfc_trans_pointer_assignment (code->expr, code->expr2);
+ return gfc_trans_pointer_assignment (code->expr1, code->expr2);
}
@@ -4035,14 +4761,22 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
if (expr1->symtree->n.sym->attr.proc_pointer
&& expr1->symtree->n.sym->attr.dummy)
- lse.expr = build_fold_indirect_ref (lse.expr);
+ lse.expr = build_fold_indirect_ref_loc (input_location,
+ lse.expr);
+
+ if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
+ && expr2->symtree->n.sym->attr.dummy)
+ rse.expr = build_fold_indirect_ref_loc (input_location,
+ rse.expr);
gfc_add_block_to_block (&block, &lse.pre);
gfc_add_block_to_block (&block, &rse.pre);
/* Check character lengths if character expression. The test is only
really added if -fbounds-check is enabled. */
- if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
+ if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
+ && !expr1->symtree->n.sym->attr.proc_pointer
+ && !gfc_is_proc_ptr_comp (expr1, NULL))
{
gcc_assert (expr2->ts.type == BT_CHARACTER);
gcc_assert (lse.string_length && rse.string_length);
@@ -4200,7 +4934,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
rse->expr, ts.kind);
}
- else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
+ else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
{
cond = NULL_TREE;
@@ -4208,8 +4942,8 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
if (r_is_var)
{
cond = fold_build2 (EQ_EXPR, boolean_type_node,
- build_fold_addr_expr (lse->expr),
- build_fold_addr_expr (rse->expr));
+ gfc_build_addr_expr (NULL_TREE, lse->expr),
+ gfc_build_addr_expr (NULL_TREE, rse->expr));
cond = gfc_evaluate_now (cond, &lse->pre);
}
@@ -4220,9 +4954,10 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
if (!l_is_temp)
{
tmp = gfc_evaluate_now (lse->expr, &lse->pre);
- tmp = gfc_deallocate_alloc_comp (ts.derived, tmp, 0);
+ tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
if (r_is_var)
- tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
+ tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
+ tmp);
gfc_add_expr_to_block (&lse->post, tmp);
}
@@ -4236,18 +4971,26 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
same as the lhs. */
if (r_is_var)
{
- tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
- tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
+ tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
+ tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
+ tmp);
gfc_add_expr_to_block (&block, tmp);
}
}
+ else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
+ {
+ gfc_add_block_to_block (&block, &lse->pre);
+ gfc_add_block_to_block (&block, &rse->pre);
+ tmp = fold_build1 (VIEW_CONVERT_EXPR, TREE_TYPE (lse->expr), rse->expr);
+ gfc_add_modify (&block, lse->expr, tmp);
+ }
else
{
gfc_add_block_to_block (&block, &lse->pre);
gfc_add_block_to_block (&block, &rse->pre);
gfc_add_modify (&block, lse->expr,
- fold_convert (TREE_TYPE (lse->expr), rse->expr));
+ fold_convert (TREE_TYPE (lse->expr), rse->expr));
}
gfc_add_block_to_block (&block, &lse->post);
@@ -4257,56 +5000,56 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
}
-/* Try to translate array(:) = func (...), where func is a transformational
- array function, without using a temporary. Returns NULL is this isn't the
- case. */
+/* There are quite a lot of restrictions on the optimisation in using an
+ array function assign without a temporary. */
-static tree
-gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
+static bool
+arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
{
- gfc_se se;
- gfc_ss *ss;
gfc_ref * ref;
bool seen_array_ref;
bool c = false;
+ gfc_symbol *sym = expr1->symtree->n.sym;
/* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
- return NULL;
+ return true;
- /* Elemental functions don't need a temporary anyway. */
+ /* Elemental functions are scalarized so that they don't need a
+ temporary in gfc_trans_assignment_1, so return a true. Otherwise,
+ they would need special treatment in gfc_trans_arrayfunc_assign. */
if (expr2->value.function.esym != NULL
&& expr2->value.function.esym->attr.elemental)
- return NULL;
+ return true;
- /* Fail if rhs is not FULL or a contiguous section. */
+ /* Need a temporary if rhs is not FULL or a contiguous section. */
if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
- return NULL;
+ return true;
- /* Fail if EXPR1 can't be expressed as a descriptor. */
+ /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
if (gfc_ref_needs_temporary_p (expr1->ref))
- return NULL;
+ return true;
/* Functions returning pointers need temporaries. */
if (expr2->symtree->n.sym->attr.pointer
|| expr2->symtree->n.sym->attr.allocatable)
- return NULL;
+ return true;
/* Character array functions need temporaries unless the
character lengths are the same. */
if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
{
- if (expr1->ts.cl->length == NULL
- || expr1->ts.cl->length->expr_type != EXPR_CONSTANT)
- return NULL;
+ if (expr1->ts.u.cl->length == NULL
+ || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+ return true;
- if (expr2->ts.cl->length == NULL
- || expr2->ts.cl->length->expr_type != EXPR_CONSTANT)
- return NULL;
+ if (expr2->ts.u.cl->length == NULL
+ || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+ return true;
- if (mpz_cmp (expr1->ts.cl->length->value.integer,
- expr2->ts.cl->length->value.integer) != 0)
- return NULL;
+ if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
+ expr2->ts.u.cl->length->value.integer) != 0)
+ return true;
}
/* Check that no LHS component references appear during an array
@@ -4320,7 +5063,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
if (ref->type == REF_ARRAY)
seen_array_ref= true;
else if (ref->type == REF_COMPONENT && seen_array_ref)
- return NULL;
+ return true;
}
/* Check for a dependency. */
@@ -4328,13 +5071,76 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
expr2->value.function.esym,
expr2->value.function.actual,
NOT_ELEMENTAL))
+ return true;
+
+ /* If we have reached here with an intrinsic function, we do not
+ need a temporary. */
+ if (expr2->value.function.isym)
+ return false;
+
+ /* If the LHS is a dummy, we need a temporary if it is not
+ INTENT(OUT). */
+ if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
+ return true;
+
+ /* A PURE function can unconditionally be called without a temporary. */
+ if (expr2->value.function.esym != NULL
+ && expr2->value.function.esym->attr.pure)
+ return false;
+
+ /* TODO a function that could correctly be declared PURE but is not
+ could do with returning false as well. */
+
+ if (!sym->attr.use_assoc
+ && !sym->attr.in_common
+ && !sym->attr.pointer
+ && !sym->attr.target
+ && expr2->value.function.esym)
+ {
+ /* A temporary is not needed if the function is not contained and
+ the variable is local or host associated and not a pointer or
+ a target. */
+ if (!expr2->value.function.esym->attr.contained)
+ return false;
+
+ /* A temporary is not needed if the lhs has never been host
+ associated and the procedure is contained. */
+ else if (!sym->attr.host_assoc)
+ return false;
+
+ /* A temporary is not needed if the variable is local and not
+ a pointer, a target or a result. */
+ if (sym->ns->parent
+ && expr2->value.function.esym->ns == sym->ns->parent)
+ return false;
+ }
+
+ /* Default to temporary use. */
+ return true;
+}
+
+
+/* Try to translate array(:) = func (...), where func is a transformational
+ array function, without using a temporary. Returns NULL if this isn't the
+ case. */
+
+static tree
+gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
+{
+ gfc_se se;
+ gfc_ss *ss;
+ gfc_component *comp = NULL;
+
+ if (arrayfunc_assign_needs_temporary (expr1, expr2))
return NULL;
/* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
functions. */
gcc_assert (expr2->value.function.isym
- || (gfc_return_by_reference (expr2->value.function.esym)
- && expr2->value.function.esym->result->attr.dimension));
+ || (gfc_is_proc_ptr_comp (expr2, &comp)
+ && comp && comp->attr.dimension)
+ || (!comp && gfc_return_by_reference (expr2->value.function.esym)
+ && expr2->value.function.esym->result->attr.dimension));
ss = gfc_walk_expr (expr1);
gcc_assert (ss != gfc_ss_terminator);
@@ -4342,7 +5148,16 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
gfc_start_block (&se.pre);
se.want_pointer = 1;
- gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL);
+ gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
+
+ if (expr1->ts.type == BT_DERIVED
+ && expr1->ts.u.derived->attr.alloc_comp)
+ {
+ tree tmp;
+ tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
+ expr1->rank);
+ gfc_add_expr_to_block (&se.pre, tmp);
+ }
se.direct_byref = 1;
se.ss = gfc_walk_expr (expr2);
@@ -4353,41 +5168,6 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
return gfc_finish_block (&se.pre);
}
-/* Determine whether the given EXPR_CONSTANT is a zero initializer. */
-
-static bool
-is_zero_initializer_p (gfc_expr * expr)
-{
- if (expr->expr_type != EXPR_CONSTANT)
- return false;
-
- /* We ignore constants with prescribed memory representations for now. */
- if (expr->representation.string)
- return false;
-
- switch (expr->ts.type)
- {
- case BT_INTEGER:
- return mpz_cmp_si (expr->value.integer, 0) == 0;
-
- case BT_REAL:
- return mpfr_zero_p (expr->value.real)
- && MPFR_SIGN (expr->value.real) >= 0;
-
- case BT_LOGICAL:
- return expr->value.logical == 0;
-
- case BT_COMPLEX:
- return mpfr_zero_p (expr->value.complex.r)
- && MPFR_SIGN (expr->value.complex.r) >= 0
- && mpfr_zero_p (expr->value.complex.i)
- && MPFR_SIGN (expr->value.complex.i) >= 0;
-
- default:
- break;
- }
- return false;
-}
/* Try to efficiently translate array(:) = 0. Return NULL if this
can't be done. */
@@ -4428,7 +5208,8 @@ gfc_trans_zero_assign (gfc_expr * expr)
len = fold_convert (size_type_node, len);
/* Construct call to __builtin_memset. */
- tmp = build_call_expr (built_in_decls[BUILT_IN_MEMSET],
+ tmp = build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_MEMSET],
3, dest, integer_zero_node, len);
return fold_convert (void_type_node, tmp);
}
@@ -4456,7 +5237,8 @@ gfc_build_memcpy_call (tree dst, tree src, tree len)
len = fold_convert (size_type_node, len);
/* Construct call to __builtin_memcpy. */
- tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
+ tmp = build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
return fold_convert (void_type_node, tmp);
}
@@ -4559,7 +5341,7 @@ gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
/* Subroutine of gfc_trans_assignment that actually scalarizes the
- assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
+ assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS. */
static tree
gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
@@ -4575,6 +5357,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
stmtblock_t body;
bool l_is_temp;
bool scalar_to_array;
+ tree string_length;
/* Assignment of the form lhs = rhs. */
gfc_start_block (&block);
@@ -4587,6 +5370,10 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
rss = NULL;
if (lss != gfc_ss_terminator)
{
+ /* Allow the scalarizer to workshare array assignments. */
+ if (ompws_flags & OMPWS_WORKSHARE_FLAG)
+ ompws_flags |= OMPWS_SCALARIZER_WS;
+
/* The assignment needs scalarization. */
lss_section = lss;
@@ -4650,10 +5437,18 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
/* Translate the expression. */
gfc_conv_expr (&rse, expr2);
+ /* Stabilize a string length for temporaries. */
+ if (expr2->ts.type == BT_CHARACTER)
+ string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
+ else
+ string_length = NULL_TREE;
+
if (l_is_temp)
{
gfc_conv_tmp_array_ref (&lse);
gfc_advance_se_ss_chain (&lse);
+ if (expr2->ts.type == BT_CHARACTER)
+ lse.string_length = string_length;
}
else
gfc_conv_expr (&lse, expr1);
@@ -4662,13 +5457,13 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
to arrays must be done with a deep copy and the rhs temporary
must have its components deallocated afterwards. */
scalar_to_array = (expr2->ts.type == BT_DERIVED
- && expr2->ts.derived->attr.alloc_comp
+ && expr2->ts.u.derived->attr.alloc_comp
&& expr2->expr_type != EXPR_VARIABLE
&& !gfc_is_constant_expr (expr2)
&& expr1->rank && !expr2->rank);
if (scalar_to_array)
{
- tmp = gfc_deallocate_alloc_comp (expr2->ts.derived, rse.expr, 0);
+ tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
gfc_add_expr_to_block (&loop.post, tmp);
}
@@ -4708,6 +5503,9 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
gcc_assert (lse.ss == gfc_ss_terminator
&& rse.ss == gfc_ss_terminator);
+ if (expr2->ts.type == BT_CHARACTER)
+ rse.string_length = string_length;
+
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
false, false);
gfc_add_expr_to_block (&body, tmp);
@@ -4755,7 +5553,7 @@ copyable_array_p (gfc_expr * expr)
return false;
case BT_DERIVED:
- return !expr->ts.derived->attr.alloc_comp;
+ return !expr->ts.u.derived->attr.alloc_comp;
default:
break;
@@ -4816,11 +5614,92 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
tree
gfc_trans_init_assign (gfc_code * code)
{
- return gfc_trans_assignment (code->expr, code->expr2, true);
+ return gfc_trans_assignment (code->expr1, code->expr2, true);
}
tree
gfc_trans_assign (gfc_code * code)
{
- return gfc_trans_assignment (code->expr, code->expr2, false);
+ return gfc_trans_assignment (code->expr1, code->expr2, false);
+}
+
+
+/* Translate an assignment to a CLASS object
+ (pointer or ordinary assignment). */
+
+tree
+gfc_trans_class_assign (gfc_code *code)
+{
+ stmtblock_t block;
+ tree tmp;
+ gfc_expr *lhs;
+ gfc_expr *rhs;
+
+ gfc_start_block (&block);
+
+ if (code->op == EXEC_INIT_ASSIGN)
+ {
+ /* Special case for initializing a CLASS variable on allocation.
+ A MEMCPY is needed to copy the full data of the dynamic type,
+ which may be different from the declared type. */
+ gfc_se dst,src;
+ tree memsz;
+ gfc_init_se (&dst, NULL);
+ gfc_init_se (&src, NULL);
+ gfc_add_component_ref (code->expr1, "$data");
+ gfc_conv_expr (&dst, code->expr1);
+ gfc_conv_expr (&src, code->expr2);
+ gfc_add_block_to_block (&block, &src.pre);
+ memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts));
+ tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz);
+ gfc_add_expr_to_block (&block, tmp);
+ return gfc_finish_block (&block);
+ }
+
+ if (code->expr2->ts.type != BT_CLASS)
+ {
+ /* Insert an additional assignment which sets the '$vptr' field. */
+ lhs = gfc_copy_expr (code->expr1);
+ gfc_add_component_ref (lhs, "$vptr");
+ if (code->expr2->ts.type == BT_DERIVED)
+ {
+ gfc_symbol *vtab;
+ gfc_symtree *st;
+ vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived);
+ gcc_assert (vtab);
+
+ rhs = gfc_get_expr ();
+ rhs->expr_type = EXPR_VARIABLE;
+ gfc_find_sym_tree (vtab->name, NULL, 1, &st);
+ rhs->symtree = st;
+ rhs->ts = vtab->ts;
+ }
+ else if (code->expr2->expr_type == EXPR_NULL)
+ rhs = gfc_int_expr (0);
+ else
+ gcc_unreachable ();
+
+ tmp = gfc_trans_pointer_assignment (lhs, rhs);
+ gfc_add_expr_to_block (&block, tmp);
+
+ gfc_free_expr (lhs);
+ gfc_free_expr (rhs);
+ }
+
+ /* Do the actual CLASS assignment. */
+ if (code->expr2->ts.type == BT_CLASS)
+ code->op = EXEC_ASSIGN;
+ else
+ gfc_add_component_ref (code->expr1, "$data");
+
+ if (code->op == EXEC_ASSIGN)
+ tmp = gfc_trans_assign (code);
+ else if (code->op == EXEC_POINTER_ASSIGN)
+ tmp = gfc_trans_pointer_assign (code);
+ else
+ gcc_unreachable();
+
+ gfc_add_expr_to_block (&block, tmp);
+
+ return gfc_finish_block (&block);
}
« no previous file with comments | « gcc/gcc/fortran/trans-decl.c ('k') | gcc/gcc/fortran/trans-intrinsic.c » ('j') | no next file with comments »

Powered by Google App Engine
This is Rietveld 408576698