This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [Patch, Fortran, F03] PR 40869: PPC assignment checking
>> So, what I did in this case was to simplify the problem by using not
>> the component itself for the comparison, but instead the symbol which
>> it gets its interface from (ts.interface). Since this is a normal
>> gfc_symbol, it can be passed to the existing gfc_compare_interfaces
>> without any problem. One drawback of this method is that the error
>> messages contain the wrong name, or an empty name (if the PPC was
>> declared like e.g. "procedure(real), pointer ..."). So far this is the
>> only drawback I see. And this method is a lot more elegant than any of
>> the other solutions I could think of.
>
> I think this solution is ok. ?You could of course add two arguments for the
> names for error messages to gfc_compare_interfaces to fix that problem, but
> I'm not sure if that's really needed (at least not for now).
Actually only one argument is needed, since only one name is used. I
have already discussed this with Tobias, and I think this is what we
should do (updated patch attached), even if it only shows the name of
the component, and not the whole thing (obj%ppc). But I think this is
ok for the purpose.
If no one objects, I will commit the updated patch later today or tomorrow.
> Or, for all of these problems you could try to rework gfc_compare_interfaces
> to work only on some common part of the things it is passed (similar to your
> polymorphism approach for gcc-in-cxx) where possible, I tried this some
> times for TBPs
You just thought about doing this, or you actually did? If you did,
can you point me at the place in the source?
I'm not completely sure what you mean, though. Like passing e.g.
sym->ts and sym->attr instead of sym? Or rather passing an actual
gfc_component for a formal gfc_symbol? (This currently won't work,
since common things like ts and attr have a different offset in both.)
Cheers,
Janus
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c (revision 151080)
+++ gcc/fortran/interface.c (working copy)
@@ -943,31 +943,31 @@ generic_correspondence (gfc_formal_argli
required to match, which is not the case for ambiguity checks.*/
int
-gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag,
- int intent_flag, char *errmsg, int err_len)
+gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
+ int generic_flag, int intent_flag,
+ char *errmsg, int err_len)
{
gfc_formal_arglist *f1, *f2;
if (s1->attr.function && (s2->attr.subroutine
|| (!s2->attr.function && s2->ts.type == BT_UNKNOWN
- && gfc_get_default_type (s2->name, s2->ns)->type == BT_UNKNOWN)))
+ && gfc_get_default_type (name2, s2->ns)->type == BT_UNKNOWN)))
{
if (errmsg != NULL)
- snprintf (errmsg, err_len, "'%s' is not a function", s2->name);
+ snprintf (errmsg, err_len, "'%s' is not a function", name2);
return 0;
}
if (s1->attr.subroutine && s2->attr.function)
{
if (errmsg != NULL)
- snprintf (errmsg, err_len, "'%s' is not a subroutine", s2->name);
+ snprintf (errmsg, err_len, "'%s' is not a subroutine", name2);
return 0;
}
/* If the arguments are functions, check type and kind
(only for dummy procedures and procedure pointer assignments). */
- if ((s1->attr.dummy || s1->attr.proc_pointer)
- && s1->attr.function && s2->attr.function)
+ if (!generic_flag && intent_flag && s1->attr.function && s2->attr.function)
{
if (s1->ts.type == BT_UNKNOWN)
return 1;
@@ -975,7 +975,7 @@ gfc_compare_interfaces (gfc_symbol *s1,
{
if (errmsg != NULL)
snprintf (errmsg, err_len, "Type/kind mismatch in return value "
- "of '%s'", s2->name);
+ "of '%s'", name2);
return 0;
}
}
@@ -1012,7 +1012,7 @@ gfc_compare_interfaces (gfc_symbol *s1,
{
if (errmsg != NULL)
snprintf (errmsg, err_len, "'%s' has the wrong number of "
- "arguments", s2->name);
+ "arguments", name2);
return 0;
}
@@ -1120,7 +1120,8 @@ check_interface1 (gfc_interface *p, gfc_
if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
continue;
- if (gfc_compare_interfaces (p->sym, q->sym, generic_flag, 0, NULL, 0))
+ if (gfc_compare_interfaces (p->sym, q->sym, NULL, generic_flag, 0,
+ NULL, 0))
{
if (referenced)
{
@@ -1403,7 +1404,7 @@ compare_parameter (gfc_symbol *formal, g
return 0;
}
- if (!gfc_compare_interfaces (formal, act_sym, 0, 1, err,
+ if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err,
sizeof(err)))
{
if (where)
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 151080)
+++ gcc/fortran/gfortran.h (working copy)
@@ -2637,7 +2637,8 @@ gfc_try gfc_ref_dimen_size (gfc_array_re
void gfc_free_interface (gfc_interface *);
int gfc_compare_derived_types (gfc_symbol *, gfc_symbol *);
int gfc_compare_types (gfc_typespec *, gfc_typespec *);
-int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, int, int, char *, int);
+int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, const char *, int, int,
+ char *, int);
void gfc_check_interfaces (gfc_namespace *);
void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *);
void gfc_ppc_use (gfc_component *, gfc_actual_arglist **, locus *);
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c (revision 151080)
+++ gcc/fortran/expr.c (working copy)
@@ -3149,6 +3149,10 @@ gfc_check_pointer_assign (gfc_expr *lval
if (proc_pointer)
{
char err[200];
+ gfc_symbol *s1,*s2;
+ gfc_component *comp;
+ const char *name;
+
attr = gfc_expr_attr (rvalue);
if (!((rvalue->expr_type == EXPR_NULL)
|| (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
@@ -3208,22 +3212,35 @@ gfc_check_pointer_assign (gfc_expr *lval
}
}
- /* TODO: Enable interface check for PPCs. */
- if (gfc_is_proc_ptr_comp (rvalue, NULL))
- return SUCCESS;
- if ((rvalue->expr_type == EXPR_VARIABLE
- && !gfc_compare_interfaces (lvalue->symtree->n.sym,
- rvalue->symtree->n.sym, 0, 1, err,
- sizeof(err)))
- || (rvalue->expr_type == EXPR_FUNCTION
- && !gfc_compare_interfaces (lvalue->symtree->n.sym,
- rvalue->symtree->n.sym->result, 0, 1,
- err, sizeof(err))))
+ if (gfc_is_proc_ptr_comp (lvalue, &comp))
+ s1 = comp->ts.interface;
+ else
+ s1 = lvalue->symtree->n.sym;
+
+ if (gfc_is_proc_ptr_comp (rvalue, &comp))
+ {
+ s2 = comp->ts.interface;
+ name = comp->name;
+ }
+ else if (rvalue->expr_type == EXPR_FUNCTION)
+ {
+ s2 = rvalue->symtree->n.sym->result;
+ name = rvalue->symtree->n.sym->result->name;
+ }
+ else
+ {
+ s2 = rvalue->symtree->n.sym;
+ name = rvalue->symtree->n.sym->name;
+ }
+
+ if (s1 && s2 && !gfc_compare_interfaces (s1, s2, name, 0, 1,
+ err, sizeof(err)))
{
gfc_error ("Interface mismatch in procedure pointer assignment "
"at %L: %s", &rvalue->where, err);
return FAILURE;
}
+
return SUCCESS;
}
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 151081)
+++ gcc/fortran/resolve.c (working copy)
@@ -8820,7 +8820,7 @@ check_generic_tbp_ambiguity (gfc_tbp_gen
}
/* Compare the interfaces. */
- if (gfc_compare_interfaces (sym1, sym2, 1, 0, NULL, 0))
+ if (gfc_compare_interfaces (sym1, sym2, NULL, 1, 0, NULL, 0))
{
gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
sym1->name, sym2->name, generic_name, &where);