re PR fortran/40869 ([F03] PPC assignment checking)
2009-08-27 Janus Weil <janus@gcc.gnu.org> PR fortran/40869 * expr.c (gfc_check_pointer_assign): Enable interface check for pointer assignments involving procedure pointer components. * gfortran.h (gfc_compare_interfaces): Modified prototype. * interface.c (gfc_compare_interfaces): Add argument 'name2', to be used instead of s2->name. Don't rely on the proc_pointer attribute, but instead on the flags handed to this function. (check_interface1,compare_parameter): Add argument for gfc_compare_interfaces. * resolve.c (check_generic_tbp_ambiguity): Ditto. 2009-08-27 Janus Weil <janus@gcc.gnu.org> PR fortran/40869 * gfortran.dg/proc_ptr_comp_20.f90: New. From-SVN: r151147
This commit is contained in:
parent
0930984ef0
commit
889dc03581
|
@ -1,3 +1,16 @@
|
|||
2009-08-27 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
PR fortran/40869
|
||||
* expr.c (gfc_check_pointer_assign): Enable interface check for
|
||||
pointer assignments involving procedure pointer components.
|
||||
* gfortran.h (gfc_compare_interfaces): Modified prototype.
|
||||
* interface.c (gfc_compare_interfaces): Add argument 'name2', to be
|
||||
used instead of s2->name. Don't rely on the proc_pointer attribute,
|
||||
but instead on the flags handed to this function.
|
||||
(check_interface1,compare_parameter): Add argument for
|
||||
gfc_compare_interfaces.
|
||||
* resolve.c (check_generic_tbp_ambiguity): Ditto.
|
||||
|
||||
2009-08-27 Daniel Kraft <d@domob.eu>
|
||||
|
||||
PR fortran/37425
|
||||
|
|
|
@ -3149,6 +3149,10 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
|
|||
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 *lvalue, gfc_expr *rvalue)
|
|||
}
|
||||
}
|
||||
|
||||
/* 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;
|
||||
}
|
||||
|
||||
|
|
|
@ -2650,7 +2650,8 @@ gfc_try gfc_ref_dimen_size (gfc_array_ref *, int dimen, mpz_t *);
|
|||
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 *);
|
||||
|
|
|
@ -943,31 +943,31 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
|
|||
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, gfc_symbol *s2, int generic_flag,
|
|||
{
|
||||
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, gfc_symbol *s2, int generic_flag,
|
|||
{
|
||||
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_interface *q0,
|
|||
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, gfc_expr *actual,
|
|||
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)
|
||||
|
|
|
@ -8851,7 +8851,7 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
|
|||
}
|
||||
|
||||
/* 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);
|
||||
|
|
|
@ -1,3 +1,8 @@
|
|||
2009-08-27 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
PR fortran/40869
|
||||
* gfortran.dg/proc_ptr_comp_20.f90: New.
|
||||
|
||||
2009-08-27 Janne Blomqvist <jb@gcc.gnu.org>
|
||||
|
||||
PR libfortran/39667
|
||||
|
|
|
@ -0,0 +1,49 @@
|
|||
! { dg-do compile }
|
||||
!
|
||||
! PR 40869: [F03] PPC assignment checking
|
||||
!
|
||||
! Contributed by Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
implicit none
|
||||
|
||||
interface func
|
||||
procedure f1,f2 ! { dg-error "Ambiguous interfaces" }
|
||||
end interface
|
||||
|
||||
interface operator(.op.)
|
||||
procedure f1,f2 ! { dg-error "Ambiguous interfaces" }
|
||||
end interface
|
||||
|
||||
type :: t1
|
||||
procedure(integer), pointer, nopass :: ppc
|
||||
end type
|
||||
|
||||
type :: t2
|
||||
procedure(real), pointer, nopass :: ppc
|
||||
end type
|
||||
|
||||
type(t1) :: o1
|
||||
type(t2) :: o2
|
||||
procedure(logical),pointer :: pp1
|
||||
procedure(complex),pointer :: pp2
|
||||
|
||||
pp1 => pp2 ! { dg-error "Type/kind mismatch" }
|
||||
pp2 => o2%ppc ! { dg-error "Type/kind mismatch" }
|
||||
|
||||
o1%ppc => pp1 ! { dg-error "Type/kind mismatch" }
|
||||
o1%ppc => o2%ppc ! { dg-error "Type/kind mismatch" }
|
||||
|
||||
contains
|
||||
|
||||
real function f1(a,b)
|
||||
real,intent(in) :: a,b
|
||||
f1 = a + b
|
||||
end function
|
||||
|
||||
integer function f2(a,b)
|
||||
real,intent(in) :: a,b
|
||||
f2 = a - b
|
||||
end function
|
||||
|
||||
end
|
||||
|
Loading…
Reference in New Issue