+ if (sym->attr.cray_pointee)
+ tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
+ gfc_get_symbol_decl (sym->cp_pointer));
+ if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+ {
+ gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
+ tmp = build_fold_addr_expr (tmp);
+ }
+ }
+ se->expr = tmp;
+}
+
+
+/* Translate the call for an elemental subroutine call used in an operator
+ assignment. This is a simplified version of gfc_conv_function_call. */
+
+tree
+gfc_conv_operator_assign (gfc_se *lse, gfc_se *rse, gfc_symbol *sym)
+{
+ tree args;
+ tree tmp;
+ gfc_se se;
+ stmtblock_t block;
+
+ /* Only elemental subroutines with two arguments. */
+ gcc_assert (sym->attr.elemental && sym->attr.subroutine);
+ gcc_assert (sym->formal->next->next == NULL);
+
+ gfc_init_block (&block);
+
+ gfc_add_block_to_block (&block, &lse->pre);
+ gfc_add_block_to_block (&block, &rse->pre);
+
+ /* Build the argument list for the call, including hidden string lengths. */
+ args = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (lse->expr));
+ args = gfc_chainon_list (args, build_fold_addr_expr (rse->expr));
+ if (lse->string_length != NULL_TREE)
+ args = gfc_chainon_list (args, lse->string_length);
+ if (rse->string_length != NULL_TREE)
+ args = gfc_chainon_list (args, rse->string_length);
+
+ /* Build the function call. */
+ gfc_init_se (&se, NULL);
+ gfc_conv_function_val (&se, sym);
+ tmp = TREE_TYPE (TREE_TYPE (TREE_TYPE (se.expr)));
+ tmp = build_call_list (tmp, se.expr, args);
+ gfc_add_expr_to_block (&block, tmp);
+
+ gfc_add_block_to_block (&block, &lse->post);
+ gfc_add_block_to_block (&block, &rse->post);
+
+ return gfc_finish_block (&block);
+}
+
+
+/* Initialize MAPPING. */
+
+void
+gfc_init_interface_mapping (gfc_interface_mapping * mapping)
+{
+ mapping->syms = NULL;
+ mapping->charlens = NULL;
+}
+
+
+/* Free all memory held by MAPPING (but not MAPPING itself). */
+
+void
+gfc_free_interface_mapping (gfc_interface_mapping * mapping)
+{
+ gfc_interface_sym_mapping *sym;
+ gfc_interface_sym_mapping *nextsym;
+ gfc_charlen *cl;
+ gfc_charlen *nextcl;
+
+ for (sym = mapping->syms; sym; sym = nextsym)
+ {
+ nextsym = sym->next;
+ gfc_free_symbol (sym->new->n.sym);
+ gfc_free (sym->new);
+ gfc_free (sym);
+ }
+ for (cl = mapping->charlens; cl; cl = nextcl)
+ {
+ nextcl = cl->next;
+ gfc_free_expr (cl->length);
+ gfc_free (cl);
+ }
+}
+
+
+/* Return a copy of gfc_charlen CL. Add the returned structure to
+ MAPPING so that it will be freed by gfc_free_interface_mapping. */
+
+static gfc_charlen *
+gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
+ gfc_charlen * cl)
+{
+ gfc_charlen *new;
+
+ new = gfc_get_charlen ();
+ new->next = mapping->charlens;
+ new->length = gfc_copy_expr (cl->length);
+
+ mapping->charlens = new;
+ return new;
+}
+
+
+/* A subroutine of gfc_add_interface_mapping. Return a descriptorless
+ array variable that can be used as the actual argument for dummy
+ argument SYM. Add any initialization code to BLOCK. PACKED is as
+ for gfc_get_nodesc_array_type and DATA points to the first element
+ in the passed array. */
+
+static tree
+gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
+ int packed, tree data)
+{
+ tree type;
+ tree var;
+
+ type = gfc_typenode_for_spec (&sym->ts);
+ type = gfc_get_nodesc_array_type (type, sym->as, packed);
+
+ var = gfc_create_var (type, "ifm");
+ gfc_add_modify_expr (block, var, fold_convert (type, data));
+
+ return var;
+}
+
+
+/* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
+ and offset of descriptorless array type TYPE given that it has the same
+ size as DESC. Add any set-up code to BLOCK. */
+
+static void
+gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
+{
+ int n;
+ tree dim;
+ tree offset;
+ tree tmp;
+
+ offset = gfc_index_zero_node;
+ for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
+ {
+ dim = gfc_rank_cst[n];
+ GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
+ if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
+ {
+ GFC_TYPE_ARRAY_LBOUND (type, n)
+ = gfc_conv_descriptor_lbound (desc, dim);
+ GFC_TYPE_ARRAY_UBOUND (type, n)
+ = gfc_conv_descriptor_ubound (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));
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ GFC_TYPE_ARRAY_LBOUND (type, n),
+ tmp);
+ tmp = gfc_evaluate_now (tmp, block);
+ GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
+ }
+ tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ GFC_TYPE_ARRAY_LBOUND (type, n),
+ GFC_TYPE_ARRAY_STRIDE (type, n));
+ offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
+ }
+ offset = gfc_evaluate_now (offset, block);
+ GFC_TYPE_ARRAY_OFFSET (type) = offset;
+}
+
+
+/* Extend MAPPING so that it maps dummy argument SYM to the value stored
+ in SE. The caller may still use se->expr and se->string_length after
+ calling this function. */
+
+void
+gfc_add_interface_mapping (gfc_interface_mapping * mapping,
+ gfc_symbol * sym, gfc_se * se)
+{
+ gfc_interface_sym_mapping *sm;
+ tree desc;
+ tree tmp;
+ tree value;
+ gfc_symbol *new_sym;
+ gfc_symtree *root;
+ gfc_symtree *new_symtree;
+
+ /* Create a new symbol to represent the actual argument. */
+ new_sym = gfc_new_symbol (sym->name, NULL);
+ new_sym->ts = sym->ts;
+ new_sym->attr.referenced = 1;
+ new_sym->attr.dimension = sym->attr.dimension;
+ new_sym->attr.pointer = sym->attr.pointer;
+ new_sym->attr.allocatable = sym->attr.allocatable;
+ new_sym->attr.flavor = sym->attr.flavor;
+
+ /* Create a fake symtree for it. */
+ root = NULL;
+ new_symtree = gfc_new_symtree (&root, sym->name);
+ new_symtree->n.sym = new_sym;
+ gcc_assert (new_symtree == root);
+
+ /* Create a dummy->actual mapping. */
+ sm = gfc_getmem (sizeof (*sm));
+ sm->next = mapping->syms;
+ sm->old = sym;
+ sm->new = new_symtree;
+ mapping->syms = sm;
+
+ /* Stabilize the argument's value. */
+ se->expr = gfc_evaluate_now (se->expr, &se->pre);
+
+ 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);
+
+ /* 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->string_length = gfc_evaluate_now (se->string_length, &se->pre);
+ new_sym->ts.cl->backend_decl = se->string_length;
+ }
+ }
+
+ /* Use the passed value as-is if the argument is a function. */
+ if (sym->attr.flavor == FL_PROCEDURE)
+ value = se->expr;
+
+ /* If the argument is either a string or a pointer to a string,
+ convert it to a boundless character type. */
+ else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
+ {
+ 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);
+ else
+ value = se->expr;
+ value = fold_convert (tmp, value);
+ }
+
+ /* 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);
+
+ /* 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);
+
+ /* If the argument is an array descriptor, use it to determine
+ information about the actual argument's shape. */
+ else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
+ && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
+ {
+ /* Get the actual argument's descriptor. */
+ desc = build_fold_indirect_ref (se->expr);
+
+ /* Create the replacement variable. */
+ tmp = gfc_conv_descriptor_data_get (desc);
+ value = gfc_get_interface_mapping_array (&se->pre, sym, 0, tmp);
+
+ /* Use DESC to work out the upper bounds, strides and offset. */
+ gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
+ }
+ else
+ /* Otherwise we have a packed array. */
+ value = gfc_get_interface_mapping_array (&se->pre, sym, 2, se->expr);
+
+ new_sym->backend_decl = value;
+}
+
+
+/* Called once all dummy argument mappings have been added to MAPPING,
+ but before the mapping is used to evaluate expressions. Pre-evaluate
+ the length of each argument, adding any initialization code to PRE and
+ any finalization code to POST. */
+
+void
+gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
+ stmtblock_t * pre, stmtblock_t * post)
+{
+ gfc_interface_sym_mapping *sym;
+ gfc_expr *expr;
+ gfc_se se;
+
+ for (sym = mapping->syms; sym; sym = sym->next)
+ if (sym->new->n.sym->ts.type == BT_CHARACTER
+ && !sym->new->n.sym->ts.cl->backend_decl)
+ {
+ expr = sym->new->n.sym->ts.cl->length;
+ gfc_apply_interface_mapping_to_expr (mapping, expr);
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, expr);
+
+ se.expr = gfc_evaluate_now (se.expr, &se.pre);
+ gfc_add_block_to_block (pre, &se.pre);
+ gfc_add_block_to_block (post, &se.post);
+
+ sym->new->n.sym->ts.cl->backend_decl = se.expr;
+ }
+}
+
+
+/* Like gfc_apply_interface_mapping_to_expr, but applied to
+ constructor C. */
+
+static void
+gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
+ gfc_constructor * c)
+{
+ for (; c; c = c->next)
+ {
+ gfc_apply_interface_mapping_to_expr (mapping, c->expr);
+ if (c->iterator)
+ {
+ gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
+ gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
+ gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
+ }
+ }
+}
+
+
+/* Like gfc_apply_interface_mapping_to_expr, but applied to
+ reference REF. */
+
+static void
+gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
+ gfc_ref * ref)
+{
+ int n;
+
+ for (; ref; ref = ref->next)
+ switch (ref->type)
+ {
+ case REF_ARRAY:
+ for (n = 0; n < ref->u.ar.dimen; n++)
+ {
+ gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
+ gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
+ gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
+ }
+ gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
+ break;
+
+ case REF_COMPONENT:
+ break;
+
+ case REF_SUBSTRING:
+ gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
+ gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
+ break;
+ }
+}
+
+
+/* EXPR is a copy of an expression that appeared in the interface
+ associated with MAPPING. Walk it recursively looking for references to
+ dummy arguments that MAPPING maps to actual arguments. Replace each such
+ reference with a reference to the associated actual argument. */
+
+static void
+gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
+ gfc_expr * expr)
+{
+ gfc_interface_sym_mapping *sym;
+ gfc_actual_arglist *actual;
+
+ if (!expr)
+ return;
+
+ /* Copying an expression does not copy its length, so do that here. */
+ if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
+ {
+ expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
+ gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
+ }
+
+ /* Apply the mapping to any references. */
+ gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
+
+ /* ...and to the expression's symbol, if it has one. */
+ if (expr->symtree)
+ for (sym = mapping->syms; sym; sym = sym->next)
+ if (sym->old == expr->symtree->n.sym)
+ expr->symtree = sym->new;
+
+ /* ...and to subexpressions in expr->value. */
+ switch (expr->expr_type)
+ {
+ case EXPR_VARIABLE:
+ case EXPR_CONSTANT:
+ case EXPR_NULL:
+ case EXPR_SUBSTRING:
+ break;
+
+ case EXPR_OP:
+ gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
+ gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
+ break;
+
+ case EXPR_FUNCTION:
+ for (sym = mapping->syms; sym; sym = sym->next)
+ if (sym->old == expr->value.function.esym)
+ expr->value.function.esym = sym->new->n.sym;
+
+ for (actual = expr->value.function.actual; actual; actual = actual->next)
+ gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
+ break;
+
+ case EXPR_ARRAY:
+ case EXPR_STRUCTURE:
+ gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
+ break;
+ }
+}
+
+
+/* Evaluate interface expression EXPR using MAPPING. Store the result
+ in SE. */
+
+void
+gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
+ gfc_se * se, gfc_expr * expr)
+{
+ expr = gfc_copy_expr (expr);
+ gfc_apply_interface_mapping_to_expr (mapping, expr);
+ gfc_conv_expr (se, expr);
+ se->expr = gfc_evaluate_now (se->expr, &se->pre);
+ gfc_free_expr (expr);
+}
+
+/* Returns a reference to a temporary array into which a component of
+ an actual argument derived type array is copied and then returned
+ after the function call.
+ TODO Get rid of this kludge, when array descriptors are capable of
+ handling arrays with a bigger stride in bytes than size. */
+
+void
+gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
+ int g77, sym_intent intent)
+{
+ gfc_se lse;
+ gfc_se rse;
+ gfc_ss *lss;
+ gfc_ss *rss;
+ gfc_loopinfo loop;
+ gfc_loopinfo loop2;
+ gfc_ss_info *info;
+ tree offset;
+ tree tmp_index;
+ tree tmp;
+ tree base_type;
+ stmtblock_t body;
+ int n;
+
+ gcc_assert (expr->expr_type == EXPR_VARIABLE);
+
+ gfc_init_se (&lse, NULL);
+ gfc_init_se (&rse, NULL);
+
+ /* Walk the argument expression. */
+ rss = gfc_walk_expr (expr);
+
+ gcc_assert (rss != gfc_ss_terminator);
+
+ /* Initialize the scalarizer. */
+ gfc_init_loopinfo (&loop);
+ gfc_add_ss_to_loop (&loop, rss);
+
+ /* Calculate the bounds of the scalarization. */
+ gfc_conv_ss_startstride (&loop);
+
+ /* Build an ss for the temporary. */
+ base_type = gfc_typenode_for_spec (&expr->ts);
+ if (GFC_ARRAY_TYPE_P (base_type)
+ || GFC_DESCRIPTOR_TYPE_P (base_type))
+ base_type = gfc_get_element_type (base_type);
+
+ loop.temp_ss = gfc_get_ss ();;
+ loop.temp_ss->type = GFC_SS_TEMP;
+ loop.temp_ss->data.temp.type = base_type;
+
+ if (expr->ts.type == BT_CHARACTER)
+ {
+ gfc_ref *char_ref = expr->ref;
+
+ for (; char_ref; char_ref = char_ref->next)
+ if (char_ref->type == REF_SUBSTRING)
+ {
+ gfc_se tmp_se;
+
+ expr->ts.cl = gfc_get_charlen ();
+ expr->ts.cl->next = char_ref->u.ss.length->next;
+ char_ref->u.ss.length->next = expr->ts.cl;
+
+ gfc_init_se (&tmp_se, NULL);
+ gfc_conv_expr_type (&tmp_se, char_ref->u.ss.end,
+ gfc_array_index_type);
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ tmp_se.expr, gfc_index_one_node);
+ tmp = gfc_evaluate_now (tmp, &parmse->pre);
+ gfc_init_se (&tmp_se, NULL);
+ gfc_conv_expr_type (&tmp_se, char_ref->u.ss.start,
+ gfc_array_index_type);
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ tmp, tmp_se.expr);
+ expr->ts.cl->backend_decl = tmp;
+
+ break;
+ }
+ loop.temp_ss->data.temp.type
+ = gfc_typenode_for_spec (&expr->ts);
+ loop.temp_ss->string_length = expr->ts.cl->backend_decl;
+ }
+
+ loop.temp_ss->data.temp.dimen = loop.dimen;
+ loop.temp_ss->next = gfc_ss_terminator;
+
+ /* Associate the SS with the loop. */
+ gfc_add_ss_to_loop (&loop, loop.temp_ss);
+
+ /* Setup the scalarizing loops. */
+ gfc_conv_loop_setup (&loop);
+
+ /* Pass the temporary descriptor back to the caller. */
+ info = &loop.temp_ss->data.info;
+ parmse->expr = info->descriptor;
+
+ /* Setup the gfc_se structures. */
+ gfc_copy_loopinfo_to_se (&lse, &loop);
+ gfc_copy_loopinfo_to_se (&rse, &loop);
+
+ rse.ss = rss;
+ lse.ss = loop.temp_ss;
+ gfc_mark_ss_chain_used (rss, 1);
+ gfc_mark_ss_chain_used (loop.temp_ss, 1);
+
+ /* Start the scalarized loop body. */
+ gfc_start_scalarized_body (&loop, &body);
+
+ /* Translate the expression. */
+ gfc_conv_expr (&rse, expr);
+
+ gfc_conv_tmp_array_ref (&lse);
+ gfc_advance_se_ss_chain (&lse);
+
+ if (intent != INTENT_OUT)
+ {
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
+ gfc_add_expr_to_block (&body, tmp);
+ gcc_assert (rse.ss == gfc_ss_terminator);
+ gfc_trans_scalarizing_loops (&loop, &body);
+ }
+ else
+ {
+ /* Make sure that the temporary declaration survives by merging
+ all the loop declarations into the current context. */
+ for (n = 0; n < loop.dimen; n++)
+ {
+ gfc_merge_block_scope (&body);
+ body = loop.code[loop.order[n]];
+ }
+ gfc_merge_block_scope (&body);