diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index fc0a0335684..95e761fb6e3 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2009-11-19 Janus Weil + + * 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 * gfortran.texi (Interoperable Subroutines and Functions): Fix diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index b72d5401bae..c0df6782750 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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);