diff options
Diffstat (limited to 'gcc/fortran/resolve.c')
| -rw-r--r-- | gcc/fortran/resolve.c | 49 |
1 files changed, 41 insertions, 8 deletions
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 6f6cb781606..8d2be53b2cd 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4781,12 +4781,6 @@ update_compcall_arglist (gfc_expr* e) if (!po) return FAILURE; - if (po->rank > 0) - { - gfc_error ("Passed-object at %L must be scalar", &e->where); - return FAILURE; - } - if (tbp->nopass || e->value.compcall.ignore_pass) { gfc_free_expr (po); @@ -4889,6 +4883,22 @@ check_typebound_baseobject (gfc_expr* e) return FAILURE; } + /* If the procedure called is NOPASS, the base object must be scalar. */ + if (e->value.compcall.tbp->nopass && base->rank > 0) + { + gfc_error ("Base object for NOPASS type-bound procedure call at %L must" + " be scalar", &e->where); + return FAILURE; + } + + /* FIXME: Remove once PR 41177 (this problem) is fixed completely. */ + if (base->rank > 0) + { + gfc_error ("Non-scalar base object at %L currently not implemented", + &e->where); + return FAILURE; + } + return SUCCESS; } @@ -10038,8 +10048,11 @@ resolve_typebound_procedure (gfc_symtree* stree) me_arg = proc->formal->sym; } - /* Now check that the argument-type matches. */ + /* Now check that the argument-type matches and the passed-object + dummy argument is generally fine. */ + gcc_assert (me_arg); + if (me_arg->ts.type != BT_CLASS) { gfc_error ("Non-polymorphic passed-object dummy argument of '%s'" @@ -10055,7 +10068,27 @@ resolve_typebound_procedure (gfc_symtree* stree) me_arg->name, &where, resolve_bindings_derived->name); goto error; } - + + gcc_assert (me_arg->ts.type == BT_CLASS); + if (me_arg->ts.u.derived->components->as + && me_arg->ts.u.derived->components->as->rank > 0) + { + gfc_error ("Passed-object dummy argument of '%s' at %L must be" + " scalar", proc->name, &where); + goto error; + } + if (me_arg->ts.u.derived->components->attr.allocatable) + { + gfc_error ("Passed-object dummy argument of '%s' at %L must not" + " be ALLOCATABLE", proc->name, &where); + goto error; + } + if (me_arg->ts.u.derived->components->attr.class_pointer) + { + gfc_error ("Passed-object dummy argument of '%s' at %L must not" + " be POINTER", proc->name, &where); + goto error; + } } /* If we are extending some type, check that we don't override a procedure |
