OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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:
Janus Weil 2009-08-27 21:48:46 +02:00
parent 0930984ef0
commit 889dc03581
7 changed files with 110 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
gcc/fortran/ChangeLog
View File

@ -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

39
gcc/fortran/expr.c
View File

@ -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;
}

3
gcc/fortran/gfortran.h
View File

@ -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 *);

23
gcc/fortran/interface.c
View File

@ -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)

2
gcc/fortran/resolve.c
View File

@ -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);

5
gcc/testsuite/ChangeLog
View File

@ -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

49
gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90 Normal file
View File

@ -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