PR fortran/40646
* dump-parse-tree.c (show_expr): Renamed 'is_proc_ptr_comp'.
* expr.c (is_proc_ptr_comp): Renamed to 'gfc_is_proc_ptr_comp'.
(gfc_check_pointer_assign): Renamed 'is_proc_ptr_comp'.
(replace_comp,gfc_expr_replace_comp): New functions, analogous
to 'replace_symbol' and 'gfc_expr_replace_symbol', just with components
instead of symbols.
* gfortran.h (gfc_expr_replace_comp): New prototype.
(is_proc_ptr_comp): Renamed to 'gfc_is_proc_ptr_comp'.
* interface.c (compare_actual_formal): Renamed 'is_proc_ptr_comp'.
* match.c (gfc_match_pointer_assignment): Ditto.
* primary.c (gfc_match_varspec): Handle array-valued procedure pointers
and procedure pointer components. Renamed 'is_proc_ptr_comp'.
* resolve.c (resolve_fl_derived): Correctly handle interfaces with
RESULT statement, and handle array-valued procedure pointer components.
(resolve_actual_arglist,resolve_ppc_call,resolve_expr_ppc): Renamed
'is_proc_ptr_comp'.
* trans-array.c (gfc_walk_function_expr): Ditto.
* trans-decl.c (gfc_get_symbol_decl): Security check for presence of
ns->proc_name.
* trans-expr.c (gfc_conv_procedure_call): Handle array-valued procedure
pointer components. Renamed 'is_proc_ptr_comp'.
(conv_function_val,gfc_trans_arrayfunc_assign): Renamed
'is_proc_ptr_comp'.
(gfc_get_proc_ptr_comp): Do not modify the argument 'e', but instead
make a copy of it.
* trans-io.c (gfc_trans_transfer): Handle array-valued procedure
pointer components.
2009-07-09 Janus Weil <janus@gcc.gnu.org>
PR fortran/40646
* gfortran.dg/proc_ptr_22.f90: New.
* gfortran.dg/proc_ptr_comp_12.f90: New.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149419
138bc75d-0d04-0410-961f-
82ee72b054a4
+2009-07-09 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/40646
+ * dump-parse-tree.c (show_expr): Renamed 'is_proc_ptr_comp'.
+ * expr.c (is_proc_ptr_comp): Renamed to 'gfc_is_proc_ptr_comp'.
+ (gfc_check_pointer_assign): Renamed 'is_proc_ptr_comp'.
+ (replace_comp,gfc_expr_replace_comp): New functions, analogous
+ to 'replace_symbol' and 'gfc_expr_replace_symbol', just with components
+ instead of symbols.
+ * gfortran.h (gfc_expr_replace_comp): New prototype.
+ (is_proc_ptr_comp): Renamed to 'gfc_is_proc_ptr_comp'.
+ * interface.c (compare_actual_formal): Renamed 'is_proc_ptr_comp'.
+ * match.c (gfc_match_pointer_assignment): Ditto.
+ * primary.c (gfc_match_varspec): Handle array-valued procedure pointers
+ and procedure pointer components. Renamed 'is_proc_ptr_comp'.
+ * resolve.c (resolve_fl_derived): Correctly handle interfaces with
+ RESULT statement, and handle array-valued procedure pointer components.
+ (resolve_actual_arglist,resolve_ppc_call,resolve_expr_ppc): Renamed
+ 'is_proc_ptr_comp'.
+ * trans-array.c (gfc_walk_function_expr): Ditto.
+ * trans-decl.c (gfc_get_symbol_decl): Security check for presence of
+ ns->proc_name.
+ * trans-expr.c (gfc_conv_procedure_call): Handle array-valued procedure
+ pointer components. Renamed 'is_proc_ptr_comp'.
+ (conv_function_val,gfc_trans_arrayfunc_assign): Renamed
+ 'is_proc_ptr_comp'.
+ (gfc_get_proc_ptr_comp): Do not modify the argument 'e', but instead
+ make a copy of it.
+ * trans-io.c (gfc_trans_transfer): Handle array-valued procedure
+ pointer components.
+
2009-07-09 Tobias Burnus <burnus@net-b.de>
PR fortran/40604
if (p->value.function.name == NULL)
{
fprintf (dumpfile, "%s", p->symtree->n.sym->name);
- if (is_proc_ptr_comp (p, NULL))
+ if (gfc_is_proc_ptr_comp (p, NULL))
show_ref (p->ref);
fputc ('[', dumpfile);
show_actual_arglist (p->value.function.actual);
else
{
fprintf (dumpfile, "%s", p->value.function.name);
- if (is_proc_ptr_comp (p, NULL))
+ if (gfc_is_proc_ptr_comp (p, NULL))
show_ref (p->ref);
fputc ('[', dumpfile);
fputc ('[', dumpfile);
}
/* TODO: Enable interface check for PPCs. */
- if (is_proc_ptr_comp (rvalue, NULL))
+ if (gfc_is_proc_ptr_comp (rvalue, NULL))
return SUCCESS;
if ((rvalue->expr_type == EXPR_VARIABLE
&& !gfc_compare_interfaces (lvalue->symtree->n.sym,
provided). */
bool
-is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp)
+gfc_is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp)
{
gfc_ref *ref;
bool ppc = false;
{
gfc_traverse_expr (expr, dest, &replace_symbol, 0);
}
+
+/* The following is analogous to 'replace_symbol', and needed for copying
+ interfaces for procedure pointer components. The argument 'sym' must formally
+ be a gfc_symbol, so that the function can be passed to gfc_traverse_expr.
+ However, it gets actually passed a gfc_component (i.e. the procedure pointer
+ component in whose formal_ns the arguments have to be). */
+
+static bool
+replace_comp (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
+{
+ gfc_component *comp;
+ comp = (gfc_component *)sym;
+ if ((expr->expr_type == EXPR_VARIABLE
+ || (expr->expr_type == EXPR_FUNCTION
+ && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
+ && expr->symtree->n.sym->ns == comp->ts.interface->formal_ns)
+ {
+ gfc_symtree *stree;
+ gfc_namespace *ns = comp->formal_ns;
+ /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
+ the symtree rather than create a new one (and probably fail later). */
+ stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
+ expr->symtree->n.sym->name);
+ gcc_assert (stree);
+ stree->n.sym->attr = expr->symtree->n.sym->attr;
+ expr->symtree = stree;
+ }
+ return false;
+}
+
+void
+gfc_expr_replace_comp (gfc_expr *expr, gfc_component *dest)
+{
+ gfc_traverse_expr (expr, (gfc_symbol *)dest, &replace_comp, 0);
+}
+
void gfc_expr_set_symbols_referenced (gfc_expr *);
gfc_try gfc_expr_check_typed (gfc_expr*, gfc_namespace*, bool);
void gfc_expr_replace_symbols (gfc_expr *, gfc_symbol *);
+void gfc_expr_replace_comp (gfc_expr *, gfc_component *);
-bool is_proc_ptr_comp (gfc_expr *, gfc_component **);
+bool gfc_is_proc_ptr_comp (gfc_expr *, gfc_component **);
/* st.c */
extern gfc_code new_st;
&& a->expr->symtree->n.sym->attr.proc_pointer)
|| (a->expr->expr_type == EXPR_FUNCTION
&& a->expr->symtree->n.sym->result->attr.proc_pointer)
- || is_proc_ptr_comp (a->expr, NULL)))
+ || gfc_is_proc_ptr_comp (a->expr, NULL)))
{
if (where)
gfc_error ("Expected a procedure pointer for argument '%s' at %L",
/* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
provided for a procedure formal argument. */
- if (a->expr->ts.type != BT_PROCEDURE && !is_proc_ptr_comp (a->expr, NULL)
+ if (a->expr->ts.type != BT_PROCEDURE && !gfc_is_proc_ptr_comp (a->expr, NULL)
&& a->expr->expr_type == EXPR_VARIABLE
&& f->sym->attr.flavor == FL_PROCEDURE)
{
}
if (lvalue->symtree->n.sym->attr.proc_pointer
- || is_proc_ptr_comp (lvalue, NULL))
+ || gfc_is_proc_ptr_comp (lvalue, NULL))
gfc_matching_procptr_assignment = 1;
m = gfc_match (" %e%t", &rvalue);
gfc_gobble_whitespace ();
if ((equiv_flag && gfc_peek_ascii_char () == '(')
- || (sym->attr.dimension && !sym->attr.proc_pointer))
+ || (sym->attr.dimension && !sym->attr.proc_pointer
+ && !gfc_is_proc_ptr_comp (primary, NULL)
+ && !(gfc_matching_procptr_assignment
+ && sym->attr.flavor == FL_PROCEDURE)))
{
/* In EQUIVALENCE, we don't know yet whether we are seeing
an array, character variable or array of character
continue;
}
- if (is_proc_ptr_comp (e, &comp))
+ if (gfc_is_proc_ptr_comp (e, &comp))
{
e->ts = comp->ts;
e->expr_type = EXPR_VARIABLE;
resolve_ppc_call (gfc_code* c)
{
gfc_component *comp;
- gcc_assert (is_proc_ptr_comp (c->expr1, &comp));
+ gcc_assert (gfc_is_proc_ptr_comp (c->expr1, &comp));
c->resolved_sym = c->expr1->symtree->n.sym;
c->expr1->expr_type = EXPR_VARIABLE;
resolve_expr_ppc (gfc_expr* e)
{
gfc_component *comp;
- gcc_assert (is_proc_ptr_comp (e, &comp));
+ gcc_assert (gfc_is_proc_ptr_comp (e, &comp));
/* Convert to EXPR_FUNCTION. */
e->expr_type = EXPR_FUNCTION;
resolve_intrinsic (ifc, &ifc->declared_at);
if (ifc->result)
- c->ts = ifc->result->ts;
- else
- c->ts = ifc->ts;
+ {
+ c->ts = ifc->result->ts;
+ c->attr.allocatable = ifc->result->attr.allocatable;
+ c->attr.pointer = ifc->result->attr.pointer;
+ c->attr.dimension = ifc->result->attr.dimension;
+ c->as = gfc_copy_array_spec (ifc->result->as);
+ }
+ else
+ {
+ c->ts = ifc->ts;
+ c->attr.allocatable = ifc->attr.allocatable;
+ c->attr.pointer = ifc->attr.pointer;
+ c->attr.dimension = ifc->attr.dimension;
+ c->as = gfc_copy_array_spec (ifc->as);
+ }
c->ts.interface = ifc;
c->attr.function = ifc->attr.function;
c->attr.subroutine = ifc->attr.subroutine;
gfc_copy_formal_args_ppc (c, ifc);
- c->attr.allocatable = ifc->attr.allocatable;
- c->attr.pointer = ifc->attr.pointer;
c->attr.pure = ifc->attr.pure;
c->attr.elemental = ifc->attr.elemental;
- c->attr.dimension = ifc->attr.dimension;
c->attr.recursive = ifc->attr.recursive;
c->attr.always_explicit = ifc->attr.always_explicit;
- /* Copy array spec. */
- c->as = gfc_copy_array_spec (ifc->as);
- /* TODO: if (c->as)
+ /* Replace symbols in array spec. */
+ if (c->as)
{
int i;
for (i = 0; i < c->as->rank; i++)
{
- gfc_expr_replace_symbols (c->as->lower[i], c);
- gfc_expr_replace_symbols (c->as->upper[i], c);
+ gfc_expr_replace_comp (c->as->lower[i], c);
+ gfc_expr_replace_comp (c->as->upper[i], c);
}
- }*/
+ }
/* Copy char length. */
if (ifc->ts.cl)
{
sym = expr->symtree->n.sym;
/* A function that returns arrays. */
- is_proc_ptr_comp (expr, &comp);
+ gfc_is_proc_ptr_comp (expr, &comp);
if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
|| (comp && comp->attr.dimension))
{
|| sym->attr.use_assoc
|| sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);
- if (sym->ns && sym->ns->proc_name->attr.function)
+ if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)
byref = gfc_return_by_reference (sym->ns->proc_name);
else
byref = 0;
{
tree tmp;
- if (is_proc_ptr_comp (expr, NULL))
+ if (gfc_is_proc_ptr_comp (expr, NULL))
tmp = gfc_get_proc_ptr_comp (se, expr);
else if (sym->attr.dummy)
{
gfc_init_se (&fptrse, NULL);
if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
- || is_proc_ptr_comp (arg->next->expr, NULL))
+ || 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 (is_proc_ptr_comp (arg->next->expr, NULL))
+ 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);
return 0;
}
}
-
+
+ gfc_is_proc_ptr_comp (expr, &comp);
+
if (se->ss != NULL)
{
if (!sym->attr.elemental)
gcc_assert (se->ss->type == GFC_SS_FUNCTION);
if (se->ss->useflags)
{
- gcc_assert (gfc_return_by_reference (sym)
- && sym->result->attr.dimension);
+ gcc_assert ((!comp && gfc_return_by_reference (sym)
+ && sym->result->attr.dimension)
+ || (comp && comp->attr.dimension));
gcc_assert (se->loop != NULL);
/* Access the previously obtained result. */
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
retargs = gfc_chainon_list (retargs, se->expr);
}
+ else if (comp && comp->attr.dimension)
+ {
+ gcc_assert (se->loop && info);
+
+ /* Set the type of the array. */
+ tmp = gfc_typenode_for_spec (&comp->ts);
+ info->dimen = se->loop->dimen;
+
+ /* Evaluate the bounds of the result, if known. */
+ gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
+
+ /* Create a temporary to store the result. In case the function
+ returns a pointer, the temporary will be a shallow copy and
+ mustn't be deallocated. */
+ callee_alloc = comp->attr.allocatable || comp->attr.pointer;
+ gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
+ NULL_TREE, false, !comp->attr.pointer,
+ 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);
+ }
else if (sym->result->attr.dimension)
{
gcc_assert (se->loop && info);
x = f()
where f is pointer valued, we have to dereference the result. */
if (!se->want_pointer && !byref && sym->attr.pointer
- && !is_proc_ptr_comp (expr, NULL))
+ && !gfc_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 (!se->direct_byref)
{
- if (sym->attr.dimension)
+ if (sym->attr.dimension || (comp && comp->attr.dimension))
{
if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
{
gfc_get_proc_ptr_comp (gfc_se *se, gfc_expr *e)
{
gfc_se comp_se;
+ gfc_expr *e2;
gfc_init_se (&comp_se, NULL);
- e->expr_type = EXPR_VARIABLE;
- gfc_conv_expr (&comp_se, e);
+ e2 = gfc_copy_expr (e);
+ e2->expr_type = EXPR_VARIABLE;
+ gfc_conv_expr (&comp_se, e2);
comp_se.expr = build_fold_addr_expr (comp_se.expr);
return gfc_evaluate_now (comp_se.expr, &se->pre);
}
/* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
functions. */
gcc_assert (expr2->value.function.isym
- || (is_proc_ptr_comp (expr2, &comp)
+ || (gfc_is_proc_ptr_comp (expr2, &comp)
&& comp && comp->attr.dimension)
|| (!comp && gfc_return_by_reference (expr2->value.function.esym)
&& expr2->value.function.esym->result->attr.dimension));
/* Transfer an array. If it is an array of an intrinsic
type, pass the descriptor to the library. Otherwise
scalarize the transfer. */
- if (expr->ref)
+ if (expr->ref && !gfc_is_proc_ptr_comp (expr, NULL))
{
for (ref = expr->ref; ref && ref->type != REF_ARRAY;
ref = ref->next);
+2009-07-09 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/40646
+ * gfortran.dg/proc_ptr_22.f90: New.
+ * gfortran.dg/proc_ptr_comp_12.f90: New.
+
2009-07-09 Jakub Jelinek <jakub@redhat.com>
PR middle-end/40692
--- /dev/null
+! { dg-do run }
+!
+! PR 40646: [F03] array-valued procedure pointer components
+!
+! Original test case by Charlie Sharpsteen <chuck@sharpsteen.net>
+! Modified by Janus Weil <janus@gcc.gnu.org>
+
+module bugTestMod
+ implicit none
+contains
+ function returnMat( a, b ) result( mat )
+ integer:: a, b
+ double precision, dimension(a,b):: mat
+ mat = 1d0
+ end function returnMat
+end module bugTestMod
+
+program bugTest
+ use bugTestMod
+ implicit none
+ procedure(returnMat), pointer :: pp
+ pp => returnMat
+ if (sum(pp(2,2))/=4) call abort()
+end program bugTest
+
+! { dg-final { cleanup-modules "bugTestMod" } }
+
--- /dev/null
+! { dg-do run }
+!
+! PR 40646: [F03] array-valued procedure pointer components
+!
+! Original test case by Charlie Sharpsteen <chuck@sharpsteen.net>
+! Modified by Janus Weil <janus@gcc.gnu.org>
+
+module bugTestMod
+ implicit none
+ type:: boundTest
+ procedure(returnMat), pointer, nopass:: test
+ end type boundTest
+contains
+ function returnMat( a, b ) result( mat )
+ integer:: a, b
+ double precision, dimension(a,b):: mat
+ mat = 1d0
+ end function returnMat
+end module bugTestMod
+
+program bugTest
+ use bugTestMod
+ implicit none
+ type( boundTest ):: testObj
+ double precision, dimension(2,2):: testCatch
+ testObj%test => returnMat
+ testCatch = testObj%test(2,2)
+ print *,testCatch
+ if (sum(testCatch)/=4) call abort()
+end program bugTest
+
+! { dg-final { cleanup-modules "bugTestMod" } }
+
OSDN Git Service
