/* Expression translation
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, tmp,
fold_convert (TREE_TYPE (tmp), integer_one_node));
tmp = gfc_evaluate_now (tmp, &se->pre);
- se->expr = build_fold_addr_expr (tmp);
+ se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
}
else
{
if (!CONSTANT_CLASS_P (end.expr) && !DECL_P (end.expr))
end.expr = gfc_evaluate_now (end.expr, &se->pre);
- if (flag_bounds_check)
+ if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
{
tree nonempty = fold_build2 (LE_EXPR, boolean_type_node,
start.expr, end.expr);
se->string_length = tmp;
}
- if (c->attr.pointer && c->attr.dimension == 0 && c->ts.type != BT_CHARACTER)
+ if ((c->attr.pointer && c->attr.dimension == 0 && c->ts.type != BT_CHARACTER)
+ || c->attr.proc_pointer)
se->expr = build_fold_indirect_ref (se->expr);
}
if (!sym->attr.dummy && !sym->attr.proc_pointer)
{
gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
- se->expr = build_fold_addr_expr (se->expr);
+ se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
}
return;
}
if (expr->ts.type == BT_CHARACTER)
gfc_conv_string_parameter (se);
else
- se->expr = build_fold_addr_expr (se->expr);
+ se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
}
}
}
static void
-gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
+conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
{
tree tmp;
- if (sym->attr.dummy)
+ if (is_proc_ptr_comp (expr, NULL))
+ tmp = gfc_get_proc_ptr_comp (se, expr);
+ else if (sym->attr.dummy)
{
tmp = gfc_get_symbol_decl (sym);
if (sym->attr.proc_pointer)
sym->backend_decl = gfc_get_extern_function_decl (sym);
tmp = sym->backend_decl;
+
if (sym->attr.cray_pointee)
- tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
- gfc_get_symbol_decl (sym->cp_pointer));
+ {
+ /* TODO - make the cray pointee a pointer to a procedure,
+ assign the pointer to it and use it for the call. This
+ will do for now! */
+ tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
+ gfc_get_symbol_decl (sym->cp_pointer));
+ tmp = gfc_evaluate_now (tmp, &se->pre);
+ }
+
if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
{
gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
- tmp = build_fold_addr_expr (tmp);
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
}
}
se->expr = tmp;
}
-/* 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_apply_interface_mapping_to_expr (mapping, expr);
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, expr);
-
+ se.expr = fold_convert (gfc_charlen_type_node, 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);
break;
case EXPR_COMPCALL:
+ case EXPR_PPC:
gcc_unreachable ();
break;
}
if (g77)
parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
else
- parmse->expr = build_fold_addr_expr (parmse->expr);
+ parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
return;
}
/* Generate code for a procedure call. Note can return se->post != NULL.
If se->direct_byref is set then se->expr contains the return parameter.
- Return nonzero, if the call has alternate specifiers. */
+ Return nonzero, if the call has alternate specifiers.
+ 'expr' is only needed for procedure pointer components. */
int
-gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
- gfc_actual_arglist * arg, tree append_args)
+gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
+ gfc_actual_arglist * arg, gfc_expr * expr,
+ tree append_args)
{
gfc_interface_mapping mapping;
tree arglist;
gfc_symbol *fsym;
stmtblock_t post;
enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
+ gfc_component *comp = NULL;
arglist = NULL_TREE;
retargs = NULL_TREE;
f = f || !sym->attr.always_explicit;
argss = gfc_walk_expr (arg->expr);
- gfc_conv_array_parameter (se, arg->expr, argss, f, NULL, NULL);
+ gfc_conv_array_parameter (se, arg->expr, argss, f,
+ NULL, NULL, NULL);
}
/* TODO -- the following two lines shouldn't be necessary, but
gfc_add_block_to_block (&se->post, &cptrse.post);
gfc_init_se (&fptrse, NULL);
- if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
- fptrse.want_pointer = 1;
+ if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
+ || 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);
- tmp = arg->next->expr->symtree->n.sym->backend_decl;
- se->expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp), fptrse.expr,
- fold_convert (TREE_TYPE (tmp), cptrse.expr));
+ if (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;
}
gfc_init_block (&post);
gfc_init_interface_mapping (&mapping);
+ is_proc_ptr_comp (expr, &comp);
need_interface_mapping = ((sym->ts.type == BT_CHARACTER
&& sym->ts.cl->length
&& sym->ts.cl->length->expr_type
!= EXPR_CONSTANT)
- || sym->attr.dimension);
+ || (comp && comp->attr.dimension)
+ || (!comp && sym->attr.dimension));
formal = sym->formal;
/* Evaluate the arguments. */
for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
if (argss == gfc_ss_terminator)
{
- if (fsym && fsym->attr.value)
+ if (e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.cray_pointee
+ && fsym && fsym->attr.flavor == FL_PROCEDURE)
+ {
+ /* The Cray pointer needs to be converted to a pointer to
+ a type given by the expression. */
+ gfc_conv_expr (&parmse, e);
+ type = build_pointer_type (TREE_TYPE (parmse.expr));
+ tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
+ parmse.expr = convert (type, tmp);
+ }
+ else if (fsym && fsym->attr.value)
{
if (fsym->ts.type == BT_CHARACTER
&& fsym->ts.is_c_interop
&& fsym && fsym->attr.target)
{
gfc_conv_expr (&parmse, e);
- parmse.expr = build_fold_addr_expr (parmse.expr);
+ parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
}
else
{
indirection. The null pointer already contains
this level of indirection. */
parm_kind = SCALAR_POINTER;
- parmse.expr = build_fold_addr_expr (parmse.expr);
+ parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
}
}
}
fsym ? fsym->attr.intent : INTENT_INOUT);
else
gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
- sym->name);
+ sym->name, NULL);
/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
allocated on entry, it must be deallocated. */
break;
}
+ if (e->expr_type == EXPR_OP
+ && e->value.op.op == INTRINSIC_PARENTHESES
+ && e->value.op.op1->expr_type == EXPR_VARIABLE)
+ {
+ tree local_tmp;
+ local_tmp = gfc_evaluate_now (tmp, &se->pre);
+ local_tmp = gfc_copy_alloc_comp (e->ts.derived, local_tmp, tmp, parm_rank);
+ gfc_add_expr_to_block (&se->post, local_tmp);
+ }
+
tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
+
gfc_add_expr_to_block (&se->post, tmp);
}
len = cl.backend_decl;
}
- byref = gfc_return_by_reference (sym);
+ byref = (comp && comp->attr.dimension)
+ || (!comp && gfc_return_by_reference (sym));
if (byref)
{
if (se->direct_byref)
/* Pass the temporary as the first argument. */
tmp = info->descriptor;
- tmp = build_fold_addr_expr (tmp);
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
retargs = gfc_chainon_list (retargs, tmp);
}
else if (ts.type == BT_CHARACTER)
var = gfc_create_var (type, "pstr");
/* Provide an address expression for the function arguments. */
- var = build_fold_addr_expr (var);
+ var = gfc_build_addr_expr (NULL_TREE, var);
}
else
var = gfc_conv_string_tmp (se, type, len);
gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
type = gfc_get_complex_type (ts.kind);
- var = build_fold_addr_expr (gfc_create_var (type, "cmplx"));
+ var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
retargs = gfc_chainon_list (retargs, var);
}
arglist = chainon (arglist, append_args);
/* Generate the actual call. */
- gfc_conv_function_val (se, sym);
+ conv_function_val (se, sym, expr);
/* If there are alternate return labels, function type should be
integer. Can't modify the type in place though, since it can be shared
TREE_TYPE (sym->backend_decl)
= build_function_type (integer_type_node,
TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
- se->expr = build_fold_addr_expr (sym->backend_decl);
+ se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
}
else
TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
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
+ && !is_proc_ptr_comp (expr, NULL))
se->expr = build_fold_indirect_ref (se->expr);
/* f2c calling conventions require a scalar default real function to
{
if (sym->attr.dimension)
{
- if (flag_bounds_check)
+ if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
{
/* Check the data pointer hasn't been modified. This would
happen in a function returning a pointer. */
}
+/* Return the backend_decl for a procedure pointer component. */
+
+tree
+gfc_get_proc_ptr_comp (gfc_se *se, gfc_expr *e)
+{
+ gfc_se comp_se;
+ gfc_init_se (&comp_se, NULL);
+ e->expr_type = EXPR_VARIABLE;
+ gfc_conv_expr (&comp_se, e);
+ comp_se.expr = build_fold_addr_expr (comp_se.expr);
+ return gfc_evaluate_now (comp_se.expr, &se->pre);
+}
+
+
/* Translate a function expression. */
static void
sym = expr->value.function.esym;
if (!sym)
sym = expr->symtree->n.sym;
- gfc_conv_function_call (se, sym, expr->value.function.actual, NULL_TREE);
+
+ gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
+ NULL_TREE);
}
continue;
val = gfc_conv_initializer (c->expr, &cm->ts,
- TREE_TYPE (cm->backend_decl), cm->attr.dimension, cm->attr.pointer);
+ TREE_TYPE (cm->backend_decl), cm->attr.dimension,
+ cm->attr.pointer || cm->attr.proc_pointer);
/* Append it to the constructor list. */
CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
gfc_add_block_to_block (&se->pre, &se->post);
/* Take the address of that value. */
- se->expr = build_fold_addr_expr (var);
+ se->expr = gfc_build_addr_expr (NULL_TREE, var);
}
tree
gfc_trans_pointer_assign (gfc_code * code)
{
- return gfc_trans_pointer_assignment (code->expr, code->expr2);
+ return gfc_trans_pointer_assignment (code->expr1, code->expr2);
}
tree tmp;
tree decl;
-
gfc_start_block (&block);
gfc_init_se (&lse, NULL);
&& expr1->symtree->n.sym->attr.dummy)
lse.expr = build_fold_indirect_ref (lse.expr);
+ if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
+ && expr2->symtree->n.sym->attr.dummy)
+ rse.expr = build_fold_indirect_ref (rse.expr);
+
gfc_add_block_to_block (&block, &lse.pre);
gfc_add_block_to_block (&block, &rse.pre);
+
+ /* Check character lengths if character expression. The test is only
+ really added if -fbounds-check is enabled. */
+ if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
+ {
+ gcc_assert (expr2->ts.type == BT_CHARACTER);
+ gcc_assert (lse.string_length && rse.string_length);
+ gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
+ lse.string_length, rse.string_length,
+ &block);
+ }
+
gfc_add_modify (&block, lse.expr,
fold_convert (TREE_TYPE (lse.expr), rse.expr));
+
gfc_add_block_to_block (&block, &rse.post);
gfc_add_block_to_block (&block, &lse.post);
}
else
{
+ tree strlen_lhs;
+ tree strlen_rhs = NULL_TREE;
+
/* Array pointer. */
gfc_conv_expr_descriptor (&lse, expr1, lss);
+ strlen_lhs = lse.string_length;
switch (expr2->expr_type)
{
case EXPR_NULL:
case EXPR_VARIABLE:
/* Assign directly to the pointer's descriptor. */
- lse.direct_byref = 1;
+ lse.direct_byref = 1;
gfc_conv_expr_descriptor (&lse, expr2, rss);
+ strlen_rhs = lse.string_length;
/* If this is a subreference array pointer assignment, use the rhs
descriptor element size for the lhs span. */
tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
if (!INTEGER_CST_P (tmp))
- gfc_add_block_to_block (&lse.post, &rse.pre);
+ gfc_add_block_to_block (&lse.post, &rse.pre);
gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
}
lse.expr = tmp;
lse.direct_byref = 1;
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);
+
+ /* Check string lengths if applicable. The check is only really added
+ to the output code if -fbounds-check is enabled. */
+ if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
+ {
+ gcc_assert (expr2->ts.type == BT_CHARACTER);
+ gcc_assert (strlen_lhs && strlen_rhs);
+ gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
+ strlen_lhs, strlen_rhs, &block);
+ }
+
gfc_add_block_to_block (&block, &lse.post);
}
return gfc_finish_block (&block);
if (r_is_var)
{
cond = fold_build2 (EQ_EXPR, boolean_type_node,
- build_fold_addr_expr (lse->expr),
- build_fold_addr_expr (rse->expr));
+ gfc_build_addr_expr (NULL_TREE, lse->expr),
+ gfc_build_addr_expr (NULL_TREE, rse->expr));
cond = gfc_evaluate_now (cond, &lse->pre);
}
gfc_ss *ss;
gfc_ref * ref;
bool seen_array_ref;
+ gfc_component *comp = NULL;
/* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
/* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
functions. */
+ is_proc_ptr_comp(expr2, &comp);
gcc_assert (expr2->value.function.isym
- || (gfc_return_by_reference (expr2->value.function.esym)
+ || (comp && comp->attr.dimension)
+ || (!comp && gfc_return_by_reference (expr2->value.function.esym)
&& expr2->value.function.esym->result->attr.dimension));
ss = gfc_walk_expr (expr1);
gfc_start_block (&se.pre);
se.want_pointer = 1;
- gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL);
+ gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL, NULL);
se.direct_byref = 1;
se.ss = gfc_walk_expr (expr2);
len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
fold_convert (gfc_array_index_type, tmp));
- /* Convert arguments to the correct types. */
+ /* If we are zeroing a local array avoid taking its address by emitting
+ a = {} instead. */
if (!POINTER_TYPE_P (TREE_TYPE (dest)))
- dest = gfc_build_addr_expr (pvoid_type_node, dest);
- else
- dest = fold_convert (pvoid_type_node, dest);
+ return build2 (MODIFY_EXPR, void_type_node,
+ dest, build_constructor (TREE_TYPE (dest), NULL));
+
+ /* Convert arguments to the correct types. */
+ dest = fold_convert (pvoid_type_node, dest);
len = fold_convert (size_type_node, len);
/* Construct call to __builtin_memset. */
stmtblock_t body;
bool l_is_temp;
bool scalar_to_array;
+ tree string_length;
/* Assignment of the form lhs = rhs. */
gfc_start_block (&block);
rss = NULL;
if (lss != gfc_ss_terminator)
{
+ /* Allow the scalarizer to workshare array assignments. */
+ if (ompws_flags & OMPWS_WORKSHARE_FLAG)
+ ompws_flags |= OMPWS_SCALARIZER_WS;
+
/* The assignment needs scalarization. */
lss_section = lss;
/* Translate the expression. */
gfc_conv_expr (&rse, expr2);
+ /* Stabilize a string length for temporaries. */
+ if (expr2->ts.type == BT_CHARACTER)
+ string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
+ else
+ string_length = NULL_TREE;
+
if (l_is_temp)
{
gfc_conv_tmp_array_ref (&lse);
gfc_advance_se_ss_chain (&lse);
+ if (expr2->ts.type == BT_CHARACTER)
+ lse.string_length = string_length;
}
else
gfc_conv_expr (&lse, expr1);
gcc_assert (lse.ss == gfc_ss_terminator
&& rse.ss == gfc_ss_terminator);
+ if (expr2->ts.type == BT_CHARACTER)
+ rse.string_length = string_length;
+
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
false, false);
gfc_add_expr_to_block (&body, tmp);
tree
gfc_trans_init_assign (gfc_code * code)
{
- return gfc_trans_assignment (code->expr, code->expr2, true);
+ return gfc_trans_assignment (code->expr1, code->expr2, true);
}
tree
gfc_trans_assign (gfc_code * code)
{
- return gfc_trans_assignment (code->expr, code->expr2, false);
+ return gfc_trans_assignment (code->expr1, code->expr2, false);
}
OSDN Git Service
