trans-expr.c (conv_isocbinding_procedure): New function.
2009-11-19 Janus Weil <janus@gcc.gnu.org> * trans-expr.c (conv_isocbinding_procedure): New function. (gfc_conv_procedure_call): Move ISO_C_BINDING stuff to separate function. From-SVN: r154327
This commit is contained in:
Janus Weil
parent
dae5882f9c
commit
08fbe2fe5e
@ -1,3 +1,9 @@
|
||||
2009-11-19 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
* trans-expr.c (conv_isocbinding_procedure): New function.
|
||||
(gfc_conv_procedure_call): Move ISO_C_BINDING stuff to
|
||||
separate function.
|
||||
|
||||
2009-11-19 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
* gfortran.texi (Interoperable Subroutines and Functions): Fix
|
||||
|
||||
@ -2533,6 +2533,150 @@ conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
|
||||
}
|
||||
|
||||
|
||||
/* 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.
|
||||
@ -2576,130 +2720,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
|
||||
len = NULL_TREE;
|
||||
gfc_clear_ts (&ts);
|
||||
|
||||
if (sym->from_intmod == INTMOD_ISO_C_BINDING)
|
||||
{
|
||||
if (sym->intmod_sym_id == ISOCBINDING_LOC)
|
||||
{
|
||||
if (arg->expr->rank == 0)
|
||||
gfc_conv_expr_reference (se, arg->expr);
|
||||
else
|
||||
{
|
||||
int f;
|
||||
/* This is really the actual arg because no formal arglist is
|
||||
created for C_LOC. */
|
||||
fsym = arg->expr->symtree->n.sym;
|
||||
|
||||
/* We should want it to do g77 calling convention. */
|
||||
f = (fsym != NULL)
|
||||
&& !(fsym->attr.pointer || fsym->attr.allocatable)
|
||||
&& fsym->as->type != AS_ASSUMED_SHAPE;
|
||||
f = f || !sym->attr.always_explicit;
|
||||
|
||||
argss = gfc_walk_expr (arg->expr);
|
||||
gfc_conv_array_parameter (se, arg->expr, argss, f,
|
||||
NULL, NULL, 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 (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 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);
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user