/* 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>
#include "system.h"
#include "coretypes.h"
#include "tree.h"
-#include "convert.h"
-#include "ggc.h"
-#include "toplev.h"
-#include "real.h"
-#include "gimple.h"
+#include "diagnostic-core.h" /* For fatal_error. */
#include "langhooks.h"
#include "flags.h"
#include "gfortran.h"
#include "arith.h"
+#include "constructor.h"
#include "trans.h"
#include "trans-const.h"
#include "trans-types.h"
tree
gfc_conv_expr_present (gfc_symbol * sym)
{
- tree decl;
+ tree decl, cond;
gcc_assert (sym->attr.dummy);
|| GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
}
- return fold_build2 (NE_EXPR, boolean_type_node, decl,
+
+ cond = fold_build2 (NE_EXPR, boolean_type_node, decl,
fold_convert (TREE_TYPE (decl), null_pointer_node));
+
+ /* Fortran 2008 allows to pass null pointers and non-associated pointers
+ as actual argument to denote absent dummies. For array descriptors,
+ we thus also need to check the array descriptor. */
+ if (!sym->attr.pointer && !sym->attr.allocatable
+ && sym->as && sym->as->type == AS_ASSUMED_SHAPE
+ && (gfc_option.allow_std & GFC_STD_F2008) != 0)
+ {
+ tree tmp;
+ tmp = build_fold_indirect_ref_loc (input_location, decl);
+ tmp = gfc_conv_array_data (tmp);
+ tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
+ fold_convert (TREE_TYPE (tmp), null_pointer_node));
+ cond = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node, cond, tmp);
+ }
+
+ return cond;
}
/* We've found what we're looking for. */
if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
{
+ gfc_constructor *c;
gfc_expr* new_expr;
+
gcc_assert (e->value.constructor);
- new_expr = e->value.constructor->expr;
- e->value.constructor->expr = NULL;
+ c = gfc_constructor_first (e->value.constructor);
+ new_expr = c->expr;
+ c->expr = NULL;
flatten_array_ctors_without_strlen (new_expr);
gfc_replace_expr (e, new_expr);
/* Otherwise, fall through to handle constructor elements. */
case EXPR_STRUCTURE:
- for (c = e->value.constructor; c; c = c->next)
+ for (c = gfc_constructor_first (e->value.constructor);
+ c; c = gfc_constructor_next (c))
flatten_array_ctors_without_strlen (c->expr);
break;
{
tree tmp;
tree type;
- tree var;
tree fault;
gfc_se start;
gfc_se end;
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);
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)
{
gfc_ref *ref;
gfc_symbol *sym;
- tree parent_decl;
+ tree parent_decl = NULL_TREE;
int parent_flag;
bool return_value;
bool alternate_entry;
entry_master = sym->attr.result
&& sym->ns->proc_name->attr.entry_master
&& !gfc_return_by_reference (sym->ns->proc_name);
- parent_decl = DECL_CONTEXT (current_function_decl);
+ if (current_function_decl)
+ parent_decl = DECL_CONTEXT (current_function_decl);
if ((se->expr == parent_decl && return_value)
|| (sym->ns && sym->ns->proc_name
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
- /* Dereference non-character pointer variables.
+ /* Dereference non-character pointer variables.
These must be dummies, results, or scalars. */
- if ((sym->attr.pointer || sym->attr.allocatable)
+ if ((sym->attr.pointer || sym->attr.allocatable
+ || gfc_is_associate_pointer (sym))
&& (sym->attr.dummy
|| sym->attr.function
|| sym->attr.result
tree var;
tree tmp;
- gcc_assert (types_compatible_p (TREE_TYPE (len), gfc_charlen_type_node));
-
if (gfc_can_put_var_on_stack (len))
{
/* Create a temporary variable to hold the result. */
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)));
lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
rse.string_length, rse.expr,
- expr->value.op.op1->ts.kind);
+ expr->value.op.op1->ts.kind,
+ code);
rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
gfc_add_block_to_block (&lse.post, &rse.post);
}
/* If a string's length is one, we convert it to a single character. */
-static tree
-string_to_single_character (tree len, tree str, int kind)
+tree
+gfc_string_to_single_character (tree len, tree str, int kind)
{
gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
- if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
- && TREE_INT_CST_HIGH (len) == 0)
+ if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0)
+ return NULL_TREE;
+
+ if (TREE_INT_CST_LOW (len) == 1)
{
str = fold_convert (gfc_get_pchar_type (kind), str);
- return build_fold_indirect_ref_loc (input_location,
- str);
+ return build_fold_indirect_ref_loc (input_location, str);
+ }
+
+ if (kind == 1
+ && TREE_CODE (str) == ADDR_EXPR
+ && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
+ && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
+ && array_ref_low_bound (TREE_OPERAND (str, 0))
+ == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
+ && TREE_INT_CST_LOW (len) > 1
+ && TREE_INT_CST_LOW (len)
+ == (unsigned HOST_WIDE_INT)
+ TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
+ {
+ tree ret = fold_convert (gfc_get_pchar_type (kind), str);
+ ret = build_fold_indirect_ref_loc (input_location, ret);
+ if (TREE_CODE (ret) == INTEGER_CST)
+ {
+ tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
+ int i, length = TREE_STRING_LENGTH (string_cst);
+ const char *ptr = TREE_STRING_POINTER (string_cst);
+
+ for (i = 1; i < length; i++)
+ if (ptr[i] != ' ')
+ return NULL_TREE;
+
+ return ret;
+ }
}
return NULL_TREE;
gfc_typespec ts;
gfc_clear_ts (&ts);
- *expr = gfc_int_expr ((int)(*expr)->value.character.string[0]);
+ *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ (int)(*expr)->value.character.string[0]);
if ((*expr)->ts.kind != gfc_c_int_kind)
{
/* The expr needs to be compatible with a C int. If the
{
if ((*expr)->ref == NULL)
{
- se->expr = string_to_single_character
+ se->expr = gfc_string_to_single_character
(build_int_cst (integer_type_node, 1),
gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
gfc_get_symbol_decl
else
{
gfc_conv_variable (se, *expr);
- se->expr = string_to_single_character
+ se->expr = gfc_string_to_single_character
(build_int_cst (integer_type_node, 1),
gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
se->expr),
}
}
+/* Helper function for gfc_build_compare_string. Return LEN_TRIM value
+ if STR is a string literal, otherwise return -1. */
+
+static int
+gfc_optimize_len_trim (tree len, tree str, int kind)
+{
+ if (kind == 1
+ && TREE_CODE (str) == ADDR_EXPR
+ && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
+ && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
+ && array_ref_low_bound (TREE_OPERAND (str, 0))
+ == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
+ && TREE_INT_CST_LOW (len) >= 1
+ && TREE_INT_CST_LOW (len)
+ == (unsigned HOST_WIDE_INT)
+ TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
+ {
+ tree folded = fold_convert (gfc_get_pchar_type (kind), str);
+ folded = build_fold_indirect_ref_loc (input_location, folded);
+ if (TREE_CODE (folded) == INTEGER_CST)
+ {
+ tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
+ int length = TREE_STRING_LENGTH (string_cst);
+ const char *ptr = TREE_STRING_POINTER (string_cst);
+
+ for (; length > 0; length--)
+ if (ptr[length - 1] != ' ')
+ break;
+
+ return length;
+ }
+ }
+ return -1;
+}
/* Compare two strings. If they are all single characters, the result is the
subtraction of them. Otherwise, we build a library call. */
tree
-gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind)
+gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
+ enum tree_code code)
{
tree sc1;
tree sc2;
- tree tmp;
+ tree fndecl;
gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
- sc1 = string_to_single_character (len1, str1, kind);
- sc2 = string_to_single_character (len2, str2, kind);
+ sc1 = gfc_string_to_single_character (len1, str1, kind);
+ sc2 = gfc_string_to_single_character (len2, str2, kind);
if (sc1 != NULL_TREE && sc2 != NULL_TREE)
{
/* Deal with single character specially. */
sc1 = fold_convert (integer_type_node, sc1);
sc2 = fold_convert (integer_type_node, sc2);
- tmp = fold_build2 (MINUS_EXPR, integer_type_node, sc1, sc2);
+ return fold_build2 (MINUS_EXPR, integer_type_node, sc1, sc2);
}
- else
- {
- /* Build a call for the comparison. */
- tree fndecl;
-
- if (kind == 1)
- fndecl = gfor_fndecl_compare_string;
- else if (kind == 4)
- fndecl = gfor_fndecl_compare_string_char4;
- else
- gcc_unreachable ();
- tmp = build_call_expr_loc (input_location,
- fndecl, 4, len1, str1, len2, str2);
+ if ((code == EQ_EXPR || code == NE_EXPR)
+ && optimize
+ && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
+ {
+ /* If one string is a string literal with LEN_TRIM longer
+ than the length of the second string, the strings
+ compare unequal. */
+ int len = gfc_optimize_len_trim (len1, str1, kind);
+ if (len > 0 && compare_tree_int (len2, len) < 0)
+ return integer_one_node;
+ len = gfc_optimize_len_trim (len2, str2, kind);
+ if (len > 0 && compare_tree_int (len1, len) < 0)
+ return integer_one_node;
}
- return tmp;
+ /* Build a call for the comparison. */
+ if (kind == 1)
+ fndecl = gfor_fndecl_compare_string;
+ else if (kind == 4)
+ fndecl = gfor_fndecl_compare_string_char4;
+ else
+ gcc_unreachable ();
+
+ return build_call_expr_loc (input_location, fndecl, 4,
+ len1, str1, len2, str2);
}
}
-/* Select a class typebound procedure at runtime. */
-static void
-select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
- tree declared, locus *where)
-{
- tree end_label;
- tree label;
- tree tmp;
- tree vindex;
- stmtblock_t body;
- gfc_class_esym_list *next_elist, *tmp_elist;
-
- /* Calculate the switch expression: class_object.vindex. */
- gcc_assert (elist->class_object->ts.type == BT_CLASS);
- tmp = elist->class_object->ts.u.derived->components->next->backend_decl;
- vindex = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
- elist->class_object->backend_decl,
- tmp, NULL_TREE);
- vindex = gfc_evaluate_now (vindex, &se->pre);
-
- /* Fix the function type to be that of the declared type. */
- 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;
-
- /* 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 (vindex),
- elist->derived->vindex);
- /* Build a label for the vindex 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;
- 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, where,
- "internal error: bad vindex in dynamic dispatch");
- gfc_add_expr_to_block (&body, tmp);
-
- /* Write the switch expression. */
- tmp = gfc_finish_block (&body);
- tmp = build3_v (SWITCH_EXPR, vindex, 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->where);
- return;
- }
-
if (gfc_is_proc_ptr_comp (expr, NULL))
tmp = get_proc_ptr_comp (expr);
else if (sym->attr.dummy)
new_sym->as = gfc_copy_array_spec (sym->as);
new_sym->attr.referenced = 1;
new_sym->attr.dimension = sym->attr.dimension;
+ new_sym->attr.contiguous = sym->attr.contiguous;
+ new_sym->attr.codimension = sym->attr.codimension;
new_sym->attr.pointer = sym->attr.pointer;
new_sym->attr.allocatable = sym->attr.allocatable;
new_sym->attr.flavor = sym->attr.flavor;
static void
gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
- gfc_constructor * c)
+ gfc_constructor_base base)
{
- for (; c; c = c->next)
+ gfc_constructor *c;
+ for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
{
gfc_apply_interface_mapping_to_expr (mapping, c->expr);
if (c->iterator)
break;
case GFC_ISYM_SIZE:
- if (!sym->as)
+ if (!sym->as || sym->as->rank == 0)
return false;
if (arg2 && arg2->expr_type == EXPR_CONSTANT)
return false;
}
- tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]), gfc_int_expr (1));
+ tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
+ gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, 1));
tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
if (new_expr)
new_expr = gfc_multiply (new_expr, tmp);
/* TODO These implementations of lbound and ubound do not limit if
the size < 0, according to F95's 13.14.53 and 13.14.113. */
- if (!sym->as)
+ if (!sym->as || sym->as->rank == 0)
return false;
if (arg2 && arg2->expr_type == EXPR_CONSTANT)
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;
tree tmp_index;
tree tmp;
tree base_type;
+ tree size;
stmtblock_t body;
int n;
+ int dimen;
gcc_assert (expr->expr_type == EXPR_VARIABLE);
if (intent != INTENT_OUT)
{
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
gfc_add_expr_to_block (&body, tmp);
gcc_assert (rse.ss == gfc_ss_terminator);
gfc_trans_scalarizing_loops (&loop, &body);
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];
gcc_assert (lse.ss == gfc_ss_terminator);
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
gfc_add_expr_to_block (&body, tmp);
/* Generate the copying loops. */
if (expr->ts.type == BT_CHARACTER)
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)
}
+/* 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);
+ gfc_trans_assign_vtab_procs (&parmse->pre, e->ts.u.derived, 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)
+ {
+ parmse->ss = NULL;
+ gfc_conv_expr_reference (parmse, e);
+ tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+ gfc_add_modify (&parmse->pre, ctree, tmp);
+ }
+ else
+ {
+ parmse->ss = ss;
+ 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.
int
gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_actual_arglist * arg, gfc_expr * expr,
- tree append_args)
+ VEC(tree,gc) *append_args)
{
gfc_interface_mapping mapping;
- tree arglist;
- tree retargs;
+ VEC(tree,gc) *arglist;
+ VEC(tree,gc) *retargs;
tree tmp;
tree fntype;
gfc_se parmse;
tree type;
tree var;
tree len;
- tree stringargs;
+ VEC(tree,gc) *stringargs;
+ tree result = NULL;
gfc_formal_arglist *formal;
int has_alternate_specifier = 0;
bool need_interface_mapping;
stmtblock_t post;
enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
gfc_component *comp = NULL;
+ int arglen;
- arglist = NULL_TREE;
- retargs = NULL_TREE;
- stringargs = NULL_TREE;
+ arglist = NULL;
+ retargs = NULL;
+ stringargs = NULL;
var = NULL_TREE;
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, 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.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 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
- || 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 (gfc_is_proc_ptr_comp (arg->next->expr, NULL))
- tmp = gfc_get_ppc_type (arg->next->expr->ref->u.c.component);
- else
- tmp = TREE_TYPE (arg->next->expr->symtree->n.sym->backend_decl);
- se->expr = fold_build2 (MODIFY_EXPR, tmp, fptrse.expr,
- fold_convert (tmp, cptrse.expr));
-
- 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 (sym->from_intmod == INTMOD_ISO_C_BINDING
+ && conv_isocbinding_procedure (se, sym, arg))
+ return 0;
gfc_is_proc_ptr_comp (expr, &comp);
if (!sym->attr.elemental)
{
gcc_assert (se->ss->type == GFC_SS_FUNCTION);
- if (se->ss->useflags)
- {
+ 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);
+ gcc_assert (se->loop != NULL);
- /* Access the previously obtained result. */
- gfc_conv_tmp_array_ref (se);
- gfc_advance_se_ss_chain (se);
- return 0;
- }
+ /* Access the previously obtained result. */
+ gfc_conv_tmp_array_ref (se);
+ gfc_advance_se_ss_chain (se);
+ return 0;
+ }
}
info = &se->ss->data.info;
}
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
}
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 (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer)
+ {
+ /* Pass a NULL pointer to denote an absent arg. */
+ gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
+ gfc_init_se (&parmse, NULL);
+ parmse.expr = null_pointer_node;
+ 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)
{
- tree data;
- tree vindex;
- tree size;
-
/* The derived type needs to be converted to a temporary
CLASS object. */
gfc_init_se (&parmse, se);
- type = gfc_typenode_for_spec (&fsym->ts);
- var = gfc_create_var (type, "class");
-
- /* Get the components. */
- tmp = fsym->ts.u.derived->components->backend_decl;
- data = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
- var, tmp, NULL_TREE);
- tmp = fsym->ts.u.derived->components->next->backend_decl;
- vindex = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
- var, tmp, NULL_TREE);
- tmp = fsym->ts.u.derived->components->next->next->backend_decl;
- size = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
- var, tmp, NULL_TREE);
-
- /* Set the vindex. */
- tmp = build_int_cst (TREE_TYPE (vindex), e->ts.u.derived->vindex);
- gfc_add_modify (&parmse.pre, vindex, tmp);
-
- /* Set the size. */
- tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&e->ts));
- gfc_add_modify (&parmse.pre, size,
- fold_convert (TREE_TYPE (size), tmp));
-
- /* Now set the data field. */
- argss = gfc_walk_expr (e);
- if (argss == gfc_ss_terminator)
- {
- gfc_conv_expr_reference (&parmse, e);
- tmp = fold_convert (TREE_TYPE (data),
- parmse.expr);
- gfc_add_modify (&parmse.pre, data, tmp);
- }
- else
- {
- gfc_conv_expr (&parmse, e);
- gfc_add_modify (&parmse.pre, data, parmse.expr);
- }
-
- /* Pass the address of the class object. */
- parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
+ 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
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)
through arg->name. */
conv_arglist_function (&parmse, arg->expr, arg->name);
else if ((e->expr_type == EXPR_FUNCTION)
- && e->symtree->n.sym->attr.pointer
- && fsym && fsym->attr.target)
+ && ((e->value.function.esym
+ && e->value.function.esym->result->attr.pointer)
+ || (!e->value.function.esym
+ && e->symtree->n.sym->attr.pointer))
+ && fsym && fsym->attr.target)
{
gfc_conv_expr (&parmse, e);
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)
&& !(e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.dummy))
|| (e->expr_type == EXPR_VARIABLE
- && gfc_is_proc_ptr_comp (e, NULL))))
+ && 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
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;
+ && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE;
+ 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))
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, 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_loc (input_location,
- parmse.expr);
- tmp = gfc_trans_dealloc_allocated (tmp);
- gfc_add_expr_to_block (&se->pre, tmp);
- }
-
+ /* 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_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 (input_location));
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
}
}
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);
}
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;
+ tree present, null_ptr, type;
if (attr->allocatable
&& (fsym == NULL || !fsym->attr.allocatable))
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));
+ null_ptr = 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);
+ present, null_ptr);
}
else
{
/* 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)
- stringargs = gfc_chainon_list (stringargs, parmse.string_length);
+ VEC_safe_push (tree, gc, stringargs, parmse.string_length);
- arglist = gfc_chainon_list (arglist, parmse.expr);
+ VEC_safe_push (tree, gc, arglist, parmse.expr);
}
gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
For dummies, we have to look through the formal argument list for
this function and use the character length found there.*/
if (!sym->attr.dummy)
- cl.backend_decl = TREE_VALUE (stringargs);
+ cl.backend_decl = VEC_index (tree, stringargs, 0);
else
{
formal = sym->ns->proc_name->formal;
cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
}
}
- else
+ else
{
tree tmp;
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
- retargs = gfc_chainon_list (retargs, se->expr);
+ result = build_fold_indirect_ref_loc (input_location,
+ se->expr);
+ VEC_safe_push (tree, gc, retargs, se->expr);
}
else if (comp && comp->attr.dimension)
{
callee_alloc, &se->ss->expr->where);
/* Pass the temporary as the first argument. */
- tmp = info->descriptor;
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
- retargs = gfc_chainon_list (retargs, tmp);
+ result = info->descriptor;
+ tmp = gfc_build_addr_expr (NULL_TREE, result);
+ VEC_safe_push (tree, gc, retargs, tmp);
}
else if (!comp && sym->result->attr.dimension)
{
callee_alloc, &se->ss->expr->where);
/* Pass the temporary as the first argument. */
- tmp = info->descriptor;
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
- retargs = gfc_chainon_list (retargs, tmp);
+ result = info->descriptor;
+ tmp = gfc_build_addr_expr (NULL_TREE, result);
+ VEC_safe_push (tree, gc, retargs, tmp);
}
else if (ts.type == BT_CHARACTER)
{
{
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 = gfc_build_addr_expr (NULL_TREE, var);
}
else
var = gfc_conv_string_tmp (se, type, len);
- retargs = gfc_chainon_list (retargs, var);
+ VEC_safe_push (tree, gc, retargs, var);
}
else
{
type = gfc_get_complex_type (ts.kind);
var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
- retargs = gfc_chainon_list (retargs, var);
+ VEC_safe_push (tree, gc, retargs, var);
}
/* Add the string length to the argument list. */
if (ts.type == BT_CHARACTER)
- retargs = gfc_chainon_list (retargs, len);
+ VEC_safe_push (tree, gc, retargs, len);
}
gfc_free_interface_mapping (&mapping);
+ /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
+ arglen = (VEC_length (tree, arglist)
+ + VEC_length (tree, stringargs) + VEC_length (tree, append_args));
+ VEC_reserve_exact (tree, gc, retargs, arglen);
+
/* Add the return arguments. */
- arglist = chainon (retargs, arglist);
+ VEC_splice (tree, retargs, arglist);
/* Add the hidden string length parameters to the arguments. */
- arglist = chainon (arglist, stringargs);
+ VEC_splice (tree, retargs, stringargs);
/* We may want to append extra arguments here. This is used e.g. for
calls to libgfortran_matmul_??, which need extra information. */
- if (append_args != NULL_TREE)
- arglist = chainon (arglist, append_args);
+ if (!VEC_empty (tree, append_args))
+ VEC_splice (tree, retargs, append_args);
+ arglist = retargs;
/* Generate the actual call. */
conv_function_val (se, sym, expr);
}
fntype = TREE_TYPE (TREE_TYPE (se->expr));
- se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist);
+ se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
/* If we have a pointer function, but we don't want a pointer, e.g.
something like
x = f()
where f is pointer valued, we have to dereference the result. */
- if (!se->want_pointer && !byref && sym->attr.pointer
+ 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);
/* 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);
if (slength != NULL_TREE)
{
slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
- ssc = string_to_single_character (slen, src, skind);
+ ssc = gfc_string_to_single_character (slen, src, skind);
}
else
{
if (dlength != NULL_TREE)
{
dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
- dsc = string_to_single_character (slen, dest, dkind);
+ dsc = gfc_string_to_single_character (dlen, dest, dkind);
}
else
{
dsc = dest;
}
- if (slength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (src)))
- ssc = string_to_single_character (slen, src, skind);
- if (dlength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (dest)))
- dsc = string_to_single_character (dlen, dest, dkind);
-
-
/* Assign directly if the types are compatible. */
if (dsc != NULL_TREE && ssc != NULL_TREE
&& TREE_TYPE (dsc) == TREE_TYPE (ssc))
if (!sym)
sym = expr->symtree->n.sym;
- gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
- NULL_TREE);
+ gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, NULL);
}
-static void
-gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
+/* Determine whether the given EXPR_CONSTANT is a zero initializer. */
+
+static bool
+is_zero_initializer_p (gfc_expr * expr)
{
- gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
- gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
+ if (expr->expr_type != EXPR_CONSTANT)
+ return false;
- gfc_conv_tmp_array_ref (se);
- gfc_advance_se_ss_chain (se);
-}
+ /* 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;
-/* Build a static initializer. EXPR is the expression for the initial value.
- The other parameters describe the variable of the component being
- initialized. EXPR may be null. */
+ 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;
+}
+
+
+static void
+gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
+{
+ gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
+ gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
+
+ gfc_conv_tmp_array_ref (se);
+ gfc_advance_se_ss_chain (se);
+}
+
+
+/* Build a static initializer. EXPR is the expression for the initial value.
+ The other parameters describe the variable of the component being
+ initialized. EXPR may be null. */
tree
gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
{
gfc_symbol *derived = expr->ts.u.derived;
- expr = gfc_int_expr (0);
-
/* The derived symbol has already been converted to a (void *). Use
its kind. */
+ expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
expr->ts.f90_type = derived->ts.f90_type;
- expr->ts.kind = derived->ts.kind;
+
+ gfc_init_se (&se, NULL);
+ gfc_conv_constant (&se, expr);
+ return se.expr;
}
if (array)
/* 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);
}
else if (pointer)
- return fold_convert (type, null_pointer_node);
+ {
+ if (!expr || expr->expr_type == EXPR_NULL)
+ return fold_convert (type, null_pointer_node);
+ else
+ {
+ gfc_init_se (&se, NULL);
+ se.want_pointer = 1;
+ gfc_conv_expr (&se, expr);
+ return se.expr;
+ }
+ }
else
{
switch (ts->type)
case BT_DERIVED:
case BT_CLASS:
gfc_init_se (&se, NULL);
- gfc_conv_structure (&se, expr, 1);
+ if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
+ gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1);
+ else
+ gfc_conv_structure (&se, expr, 1);
return se.expr;
case BT_CHARACTER:
gfc_conv_expr (&rse, expr);
- tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
+ tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
gfc_add_expr_to_block (&body, tmp);
gcc_assert (rse.ss == gfc_ss_terminator);
}
+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
gfc_ss *rss;
stmtblock_t block;
tree tmp;
- tree offset;
- int n;
gfc_start_block (&block);
{
/* NULL initialization for CLASS components. */
tmp = gfc_trans_structure_assign (dest,
- gfc_default_initializer (&cm->ts));
+ gfc_class_null_initializer (&cm->ts));
gfc_add_expr_to_block (&block, tmp);
}
else if (cm->attr.dimension)
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);
- gfc_add_modify (&block, dest, se.expr);
-
- 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);
-
+ 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_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++)
- {
- if (expr->expr_type != EXPR_VARIABLE
- && expr->expr_type != EXPR_CONSTANT)
- {
- tree span;
- 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, gfc_index_one_node);
- gfc_conv_descriptor_ubound_set (&block, dest, gfc_rank_cst[n],
- tmp);
- gfc_conv_descriptor_lbound_set (&block, dest, gfc_rank_cst[n],
- gfc_index_one_node);
- }
- 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 (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
{
if (cm->ts.type == BT_CHARACTER)
lse.string_length = cm->ts.u.cl->backend_decl;
lse.expr = dest;
- tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
+ tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
gfc_add_expr_to_block (&block, tmp);
}
return gfc_finish_block (&block);
gfc_start_block (&block);
cm = expr->ts.u.derived->components;
- for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
+ for (c = gfc_constructor_first (expr->value.constructor);
+ c; c = gfc_constructor_next (c), 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);
cm = expr->ts.u.derived->components;
- for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
+ for (c = gfc_constructor_first (expr->value.constructor);
+ c; c = gfc_constructor_next (c), cm = cm->next)
{
/* Skip absent members in default initializers and allocatable
components. Although the latter have a default initializer
if (!c->expr || cm->attr.allocatable)
continue;
- if (cm->ts.type == BT_CLASS)
+ if (strcmp (cm->name, "$size") == 0)
{
- val = gfc_conv_initializer (c->expr, &cm->ts,
- TREE_TYPE (cm->ts.u.derived->components->backend_decl),
- cm->ts.u.derived->components->attr.dimension,
- cm->ts.u.derived->components->attr.pointer);
-
- /* Append it to the constructor list. */
- CONSTRUCTOR_APPEND_ELT (v, cm->ts.u.derived->components->backend_decl,
- val);
+ 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)
+ {
+ tree vtab;
+ gfc_symbol *vtabs;
+ vtabs = cm->initializer->symtree->n.sym;
+ vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
+ CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
}
else
{
/* 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;
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;
}
}
if (expr->expr_type == EXPR_FUNCTION
- && expr->symtree->n.sym->attr.pointer
- && !expr->symtree->n.sym->attr.dimension)
+ && ((expr->value.function.esym
+ && expr->value.function.esym->result->attr.pointer
+ && !expr->value.function.esym->result->attr.dimension)
+ || (!expr->value.function.esym
+ && expr->symtree->n.sym->attr.pointer
+ && !expr->symtree->n.sym->attr.dimension)))
{
se->want_pointer = 1;
gfc_conv_expr (se, expr);
}
else
{
+ gfc_ref* remap;
+ bool rank_remap;
tree strlen_lhs;
tree strlen_rhs = NULL_TREE;
- /* Array pointer. */
+ /* Array pointer. Find the last reference on the LHS and if it is an
+ array section ref, we're dealing with bounds remapping. In this case,
+ set it to AR_FULL so that gfc_conv_expr_descriptor does
+ not see it and process the bounds remapping afterwards explicitely. */
+ for (remap = expr1->ref; remap; remap = remap->next)
+ if (!remap->next && remap->type == REF_ARRAY
+ && remap->u.ar.type == AR_SECTION)
+ {
+ remap->u.ar.type = AR_FULL;
+ break;
+ }
+ rank_remap = (remap && remap->u.ar.end[0]);
+
gfc_conv_expr_descriptor (&lse, expr1, lss);
strlen_lhs = lse.string_length;
- switch (expr2->expr_type)
+ desc = lse.expr;
+
+ if (expr2->expr_type == EXPR_NULL)
{
- case EXPR_NULL:
/* Just set the data pointer to null. */
gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
- break;
-
- case EXPR_VARIABLE:
- /* Assign directly to the pointer's descriptor. */
+ }
+ else if (rank_remap)
+ {
+ /* If we are rank-remapping, just get the RHS's descriptor and
+ process this later on. */
+ gfc_init_se (&rse, NULL);
+ rse.direct_byref = 1;
+ rse.byref_noassign = 1;
+ gfc_conv_expr_descriptor (&rse, expr2, rss);
+ strlen_rhs = rse.string_length;
+ }
+ else if (expr2->expr_type == EXPR_VARIABLE)
+ {
+ /* Assign directly to the LHS's descriptor. */
lse.direct_byref = 1;
gfc_conv_expr_descriptor (&lse, expr2, rss);
strlen_rhs = lse.string_length;
gfc_add_block_to_block (&lse.post, &rse.pre);
gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
}
-
- break;
-
- default:
+ }
+ else
+ {
/* Assign to a temporary descriptor and then copy that
temporary to the pointer. */
- desc = lse.expr;
tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
lse.expr = tmp;
gfc_conv_expr_descriptor (&lse, expr2, rss);
strlen_rhs = lse.string_length;
gfc_add_modify (&lse.pre, desc, tmp);
- break;
}
gfc_add_block_to_block (&block, &lse.pre);
+ if (rank_remap)
+ gfc_add_block_to_block (&block, &rse.pre);
+
+ /* If we do bounds remapping, update LHS descriptor accordingly. */
+ if (remap)
+ {
+ int dim;
+ gcc_assert (remap->u.ar.dimen == expr1->rank);
+
+ if (rank_remap)
+ {
+ /* Do rank remapping. We already have the RHS's descriptor
+ converted in rse and now have to build the correct LHS
+ descriptor for it. */
+
+ tree dtype, data;
+ tree offs, stride;
+ tree lbound, ubound;
+
+ /* Set dtype. */
+ dtype = gfc_conv_descriptor_dtype (desc);
+ tmp = gfc_get_dtype (TREE_TYPE (desc));
+ gfc_add_modify (&block, dtype, tmp);
+
+ /* Copy data pointer. */
+ data = gfc_conv_descriptor_data_get (rse.expr);
+ gfc_conv_descriptor_data_set (&block, desc, data);
+
+ /* Copy offset but adjust it such that it would correspond
+ to a lbound of zero. */
+ offs = gfc_conv_descriptor_offset_get (rse.expr);
+ for (dim = 0; dim < expr2->rank; ++dim)
+ {
+ stride = gfc_conv_descriptor_stride_get (rse.expr,
+ gfc_rank_cst[dim]);
+ lbound = gfc_conv_descriptor_lbound_get (rse.expr,
+ gfc_rank_cst[dim]);
+ tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ stride, lbound);
+ offs = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ offs, tmp);
+ }
+ gfc_conv_descriptor_offset_set (&block, desc, offs);
+
+ /* Set the bounds as declared for the LHS and calculate strides as
+ well as another offset update accordingly. */
+ stride = gfc_conv_descriptor_stride_get (rse.expr,
+ gfc_rank_cst[0]);
+ for (dim = 0; dim < expr1->rank; ++dim)
+ {
+ gfc_se lower_se;
+ gfc_se upper_se;
+
+ gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
+
+ /* Convert declared bounds. */
+ gfc_init_se (&lower_se, NULL);
+ gfc_init_se (&upper_se, NULL);
+ gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
+ gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
+
+ gfc_add_block_to_block (&block, &lower_se.pre);
+ gfc_add_block_to_block (&block, &upper_se.pre);
+
+ lbound = fold_convert (gfc_array_index_type, lower_se.expr);
+ ubound = fold_convert (gfc_array_index_type, upper_se.expr);
+
+ lbound = gfc_evaluate_now (lbound, &block);
+ ubound = gfc_evaluate_now (ubound, &block);
+
+ gfc_add_block_to_block (&block, &lower_se.post);
+ gfc_add_block_to_block (&block, &upper_se.post);
+
+ /* Set bounds in descriptor. */
+ gfc_conv_descriptor_lbound_set (&block, desc,
+ gfc_rank_cst[dim], lbound);
+ gfc_conv_descriptor_ubound_set (&block, desc,
+ gfc_rank_cst[dim], ubound);
+
+ /* Set stride. */
+ stride = gfc_evaluate_now (stride, &block);
+ gfc_conv_descriptor_stride_set (&block, desc,
+ gfc_rank_cst[dim], stride);
+
+ /* Update offset. */
+ offs = gfc_conv_descriptor_offset_get (desc);
+ tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ lbound, stride);
+ offs = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ offs, tmp);
+ offs = gfc_evaluate_now (offs, &block);
+ gfc_conv_descriptor_offset_set (&block, desc, offs);
+
+ /* Update stride. */
+ tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+ stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ stride, tmp);
+ }
+ }
+ else
+ {
+ /* Bounds remapping. Just shift the lower bounds. */
+
+ gcc_assert (expr1->rank == expr2->rank);
+
+ for (dim = 0; dim < remap->u.ar.dimen; ++dim)
+ {
+ gfc_se lbound_se;
+
+ gcc_assert (remap->u.ar.start[dim]);
+ gcc_assert (!remap->u.ar.end[dim]);
+ gfc_init_se (&lbound_se, NULL);
+ gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
+
+ gfc_add_block_to_block (&block, &lbound_se.pre);
+ gfc_conv_shift_descriptor_lbound (&block, desc,
+ dim, lbound_se.expr);
+ gfc_add_block_to_block (&block, &lbound_se.post);
+ }
+ }
+ }
/* Check string lengths if applicable. The check is only really added
to the output code if -fbounds-check is enabled. */
strlen_lhs, strlen_rhs, &block);
}
+ /* If rank remapping was done, check with -fcheck=bounds that
+ the target is at least as large as the pointer. */
+ if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
+ {
+ tree lsize, rsize;
+ tree fault;
+ const char* msg;
+
+ lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
+ rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
+
+ lsize = gfc_evaluate_now (lsize, &block);
+ rsize = gfc_evaluate_now (rsize, &block);
+ fault = fold_build2 (LT_EXPR, boolean_type_node, rsize, lsize);
+
+ msg = _("Target of rank remapping is too small (%ld < %ld)");
+ gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
+ msg, rsize, lsize);
+ }
+
gfc_add_block_to_block (&block, &lse.post);
+ if (rank_remap)
+ gfc_add_block_to_block (&block, &rse.post);
}
+
return gfc_finish_block (&block);
}
/* Generate code for assignment of scalar variables. Includes character
- strings and derived types with allocatable components. */
+ strings and derived types with allocatable components.
+ If you know that the LHS has no allocations, set dealloc to false. */
tree
gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
- bool l_is_temp, bool r_is_var)
+ bool l_is_temp, bool r_is_var, bool dealloc)
{
stmtblock_t block;
tree tmp;
the same as the rhs. This must be done following the assignment
to prevent deallocating data that could be used in the rhs
expression. */
- if (!l_is_temp)
+ if (!l_is_temp && dealloc)
{
tmp = gfc_evaluate_now (lse->expr, &lse->pre);
tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
gfc_add_expr_to_block (&block, tmp);
}
}
- else if (ts.type == BT_DERIVED)
+ 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 = gfc_evaluate_now (rse->expr, &block);
- tmp = fold_build1 (VIEW_CONVERT_EXPR, TREE_TYPE (lse->expr), tmp);
+ tmp = fold_build1 (VIEW_CONVERT_EXPR, TREE_TYPE (lse->expr), rse->expr);
gfc_add_modify (&block, lse->expr, tmp);
}
else
}
-/* 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_component *comp = NULL;
+ 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 (expr1->ts.u.cl->length == NULL
|| expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
- return NULL;
+ return true;
if (expr2->ts.u.cl->length == NULL
|| expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
- return NULL;
+ return true;
if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
expr2->ts.u.cl->length->value.integer) != 0)
- return NULL;
+ return true;
}
/* Check that no LHS component references appear during an array
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. */
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
gfc_start_block (&se.pre);
se.want_pointer = 1;
- gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, 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);
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 (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;
-}
/* Try to efficiently translate array(:) = 0. Return NULL if this
can't be done. */
/* Subroutine of gfc_trans_assignment that actually scalarizes the
- assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS. */
+ assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
+ init_flag indicates initialization expressions and dealloc that no
+ deallocate prior assignment is needed (if in doubt, set true). */
static tree
-gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
+gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
+ bool dealloc)
{
gfc_se lse;
gfc_se rse;
bool l_is_temp;
bool scalar_to_array;
tree string_length;
+ int n;
/* Assignment of the form lhs = rhs. */
gfc_start_block (&block);
/* Calculate the bounds of the scalarization. */
gfc_conv_ss_startstride (&loop);
+ /* Enable loop reversal. */
+ for (n = 0; n < loop.dimen; n++)
+ loop.reverse[n] = GFC_REVERSE_NOT_SET;
/* Resolve any data dependencies in the statement. */
gfc_conv_resolve_dependencies (&loop, lss, rss);
/* Setup the scalarizing loops. */
&& expr2->expr_type != EXPR_VARIABLE
&& !gfc_is_constant_expr (expr2)
&& expr1->rank && !expr2->rank);
- if (scalar_to_array)
+ if (scalar_to_array && dealloc)
{
tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
gfc_add_expr_to_block (&loop.post, tmp);
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
l_is_temp || init_flag,
(expr2->expr_type == EXPR_VARIABLE)
- || scalar_to_array);
+ || scalar_to_array, dealloc);
gfc_add_expr_to_block (&body, tmp);
if (lss == gfc_ss_terminator)
rse.string_length = string_length;
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
- false, false);
+ false, false, dealloc);
gfc_add_expr_to_block (&body, tmp);
}
/* Translate an assignment. */
tree
-gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
+gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
+ bool dealloc)
{
tree tmp;
}
/* Fallback to the scalarizer to generate explicit loops. */
- return gfc_trans_assignment_1 (expr1, expr2, init_flag);
+ return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
}
tree
gfc_trans_init_assign (gfc_code * code)
{
- return gfc_trans_assignment (code->expr1, code->expr2, true);
+ return gfc_trans_assignment (code->expr1, code->expr2, true, false);
}
tree
gfc_trans_assign (gfc_code * code)
{
- return gfc_trans_assignment (code->expr1, code->expr2, false);
+ return gfc_trans_assignment (code->expr1, code->expr2, false, true);
+}
+
+
+/* Generate code to assign typebound procedures to a derived vtab. */
+void gfc_trans_assign_vtab_procs (stmtblock_t *block, gfc_symbol *dt,
+ gfc_symbol *vtab)
+{
+ gfc_component *cmp;
+ tree vtb, ctree, proc, cond = NULL_TREE;
+ stmtblock_t body;
+
+ /* Point to the first procedure pointer. */
+ cmp = gfc_find_component (vtab->ts.u.derived, "$extends", true, true);
+ cmp = cmp->next;
+ if (!cmp)
+ return;
+
+ vtb = gfc_get_symbol_decl (vtab);
+
+ ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl), vtb,
+ cmp->backend_decl, NULL_TREE);
+ cond = fold_build2 (EQ_EXPR, boolean_type_node, ctree,
+ build_int_cst (TREE_TYPE (ctree), 0));
+
+ gfc_init_block (&body);
+ for (; cmp; cmp = cmp->next)
+ {
+ gfc_symbol *target = NULL;
+
+ /* This is required when typebound generic procedures are called
+ with derived type targets. The specific procedures do not get
+ added to the vtype, which remains "empty". */
+ if (cmp->tb && cmp->tb->u.specific && cmp->tb->u.specific->n.sym)
+ target = cmp->tb->u.specific->n.sym;
+ else
+ {
+ gfc_symtree *st;
+ st = gfc_find_typebound_proc (dt, NULL, cmp->name, false, NULL);
+ if (st->n.tb && st->n.tb->u.specific)
+ target = st->n.tb->u.specific->n.sym;
+ }
+
+ if (!target)
+ continue;
+
+ ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+ vtb, cmp->backend_decl, NULL_TREE);
+ proc = gfc_get_symbol_decl (target);
+ proc = gfc_build_addr_expr (TREE_TYPE (ctree), proc);
+ gfc_add_modify (&body, ctree, proc);
+ }
+
+ proc = gfc_finish_block (&body);
+
+ proc = build3_v (COND_EXPR, cond, proc, build_empty_stmt (input_location));
+
+ gfc_add_expr_to_block (block, proc);
+}
+
+
+/* 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. */
+
+tree
+gfc_trans_class_init_assign (gfc_code *code)
+{
+ stmtblock_t block;
+ tree tmp, memsz;
+ gfc_se dst,src;
+
+ gfc_start_block (&block);
+
+ 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);
}
(pointer or ordinary assignment). */
tree
-gfc_trans_class_assign (gfc_code *code)
+gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
{
stmtblock_t block;
tree tmp;
+ gfc_expr *lhs;
+ gfc_expr *rhs;
gfc_start_block (&block);
- if (code->expr2->ts.type != BT_CLASS)
- {
- /* Insert an additional assignment which sets the '$vindex' field. */
- gfc_expr *lhs,*rhs;
- lhs = gfc_copy_expr (code->expr1);
- gfc_add_component_ref (lhs, "$vindex");
- if (code->expr2->ts.type == BT_DERIVED)
- /* vindex is constant, determined at compile time. */
- rhs = gfc_int_expr (code->expr2->ts.u.derived->vindex);
- else if (code->expr2->expr_type == EXPR_NULL)
- rhs = gfc_int_expr (0);
- else
- gcc_unreachable ();
- tmp = gfc_trans_assignment (lhs, rhs, false);
- gfc_add_expr_to_block (&block, tmp);
-
- /* Insert another assignment which sets the '$size' field. */
- lhs = gfc_copy_expr (code->expr1);
- gfc_add_component_ref (lhs, "$size");
- if (code->expr2->ts.type == BT_DERIVED)
- {
- /* Size is fixed at compile time. */
- gfc_se lse;
- gfc_init_se (&lse, NULL);
- gfc_conv_expr (&lse, lhs);
- tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts));
- gfc_add_modify (&block, lse.expr,
- fold_convert (TREE_TYPE (lse.expr), tmp));
- }
- else if (code->expr2->expr_type == EXPR_NULL)
+ if (expr2->ts.type != BT_CLASS)
+ {
+ /* Insert an additional assignment which sets the '$vptr' field. */
+ lhs = gfc_copy_expr (expr1);
+ gfc_add_component_ref (lhs, "$vptr");
+ if (expr2->ts.type == BT_DERIVED)
{
- rhs = gfc_int_expr (0);
- tmp = gfc_trans_assignment (lhs, rhs, false);
- gfc_add_expr_to_block (&block, tmp);
+ gfc_symbol *vtab;
+ gfc_symtree *st;
+ vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
+ gcc_assert (vtab);
+ gfc_trans_assign_vtab_procs (&block, expr2->ts.u.derived, 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 (expr2->expr_type == EXPR_NULL)
+ rhs = gfc_get_int_expr (gfc_default_integer_kind, NULL, 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;
+ if (expr2->ts.type == BT_CLASS)
+ op = EXEC_ASSIGN;
else
- gfc_add_component_ref (code->expr1, "$data");
+ gfc_add_component_ref (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);
+ if (op == EXEC_ASSIGN)
+ tmp = gfc_trans_assignment (expr1, expr2, false, true);
+ else if (op == EXEC_POINTER_ASSIGN)
+ tmp = gfc_trans_pointer_assignment (expr1, expr2);
else
gcc_unreachable();