diff options
| author | janus <janus@138bc75d-0d04-0410-961f-82ee72b054a4> | 2015-01-02 11:24:32 +0000 |
|---|---|---|
| committer | janus <janus@138bc75d-0d04-0410-961f-82ee72b054a4> | 2015-01-02 11:24:32 +0000 |
| commit | 23d48c0504e3d136f63a59c65de9607c30815d2c (patch) | |
| tree | 542766813f11cd3b0d5385996b80feeea40828ca /gcc/fortran/interface.c | |
| parent | edf5ad4fd266b75b545390d03a5eb247c68e442b (diff) | |
| download | gcc-23d48c0504e3d136f63a59c65de9607c30815d2c.tar.gz | |
2015-01-02 Janus Weil <janus@gcc.gnu.org>
PR fortran/60507
* interface.c (is_procptr_result): New function to check if an
expression is a procedure-pointer result.
(compare_actual_formal): Use it.
2015-01-02 Janus Weil <janus@gcc.gnu.org>
PR fortran/60507
* gfortran.dg/dummy_procedure_11: New.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@219141 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/fortran/interface.c')
| -rw-r--r-- | gcc/fortran/interface.c | 25 |
1 files changed, 21 insertions, 4 deletions
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 04bcf12864b..a797f1aace7 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -2503,6 +2503,18 @@ gfc_has_vector_subscript (gfc_expr *e) } +static bool +is_procptr_result (gfc_expr *expr) +{ + gfc_component *c = gfc_get_proc_ptr_comp (expr); + if (c) + return (c->ts.interface && (c->ts.interface->attr.proc_pointer == 1)); + else + return ((expr->symtree->n.sym->result != expr->symtree->n.sym) + && (expr->symtree->n.sym->result->attr.proc_pointer == 1)); +} + + /* Given formal and actual argument lists, see if they are compatible. If they are compatible, the actual argument list is sorted to correspond with the formal list, and elements for missing optional @@ -2724,10 +2736,10 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, argument is provided for a procedure pointer formal argument. */ if (f->sym->attr.proc_pointer && !((a->expr->expr_type == EXPR_VARIABLE - && a->expr->symtree->n.sym->attr.proc_pointer) + && (a->expr->symtree->n.sym->attr.proc_pointer + || gfc_is_proc_ptr_comp (a->expr))) || (a->expr->expr_type == EXPR_FUNCTION - && a->expr->symtree->n.sym->result->attr.proc_pointer) - || gfc_is_proc_ptr_comp (a->expr))) + && is_procptr_result (a->expr)))) { if (where) gfc_error ("Expected a procedure pointer for argument %qs at %L", @@ -2738,7 +2750,12 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is provided for a procedure formal argument. */ if (f->sym->attr.flavor == FL_PROCEDURE - && gfc_expr_attr (a->expr).flavor != FL_PROCEDURE) + && !((a->expr->expr_type == EXPR_VARIABLE + && (a->expr->symtree->n.sym->attr.flavor == FL_PROCEDURE + || a->expr->symtree->n.sym->attr.proc_pointer + || gfc_is_proc_ptr_comp (a->expr))) + || (a->expr->expr_type == EXPR_FUNCTION + && is_procptr_result (a->expr)))) { if (where) gfc_error ("Expected a procedure for argument %qs at %L", |