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

re PR fortran/77596 ([F03] procedure pointer component with implicit interface can point to a function)

Browse Source 
2016-11-08  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/77596
	* expr.c (gfc_check_pointer_assign): Add special check for procedure-
	pointer component with absent interface.

2016-11-08  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/77596
	* gfortran.dg/proc_ptr_comp_46.f90: New test.

From-SVN: r241972
This commit is contained in:
Janus Weil 2016-11-08 17:10:56 +01:00
parent c22d878716
commit eba5aec8e3
4 changed files with 58 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gcc/fortran/ChangeLog
View File

@ -1,3 +1,9 @@
2016-11-08 Janus Weil <janus@gcc.gnu.org>
PR fortran/77596
* expr.c (gfc_check_pointer_assign): Add special check for procedure-
pointer component with absent interface.
2016-11-07 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/78226

27
gcc/fortran/expr.c
View File

@ -3445,7 +3445,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
{
char err[200];
gfc_symbol *s1,*s2;
gfc_component *comp;
gfc_component *comp1, *comp2;
const char *name;
attr = gfc_expr_attr (rvalue);
@ -3549,9 +3549,9 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
}
}
comp = gfc_get_proc_ptr_comp (lvalue);
if (comp)
s1 = comp->ts.interface;
comp1 = gfc_get_proc_ptr_comp (lvalue);
if (comp1)
s1 = comp1->ts.interface;
else
{
s1 = lvalue->symtree->n.sym;
@ -3559,18 +3559,18 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
s1 = s1->ts.interface;
}
comp = gfc_get_proc_ptr_comp (rvalue);
if (comp)
comp2 = gfc_get_proc_ptr_comp (rvalue);
if (comp2)
{
if (rvalue->expr_type == EXPR_FUNCTION)
{
s2 = comp->ts.interface->result;
s2 = comp2->ts.interface->result;
name = s2->name;
}
else
{
s2 = comp->ts.interface;
name = comp->name;
s2 = comp2->ts.interface;
name = comp2->name;
}
}
else if (rvalue->expr_type == EXPR_FUNCTION)
@ -3591,6 +3591,15 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
if (s2 && s2->attr.proc_pointer && s2->ts.interface)
s2 = s2->ts.interface;
/* Special check for the case of absent interface on the lvalue.
* All other interface checks are done below. */
if (!s1 && comp1 && comp1->attr.subroutine && s2 && s2->attr.function)
{
gfc_error ("Interface mismatch in procedure pointer assignment "
"at %L: '%s' is not a subroutine", &rvalue->where, name);
return false;
}
if (s1 == s2 || !s1 || !s2)
return true;

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2016-11-08 Janus Weil <janus@gcc.gnu.org>
PR fortran/77596
* gfortran.dg/proc_ptr_comp_46.f90: New test.
2016-11-08 Bin Cheng <bin.cheng@arm.com>
* gcc.dg/vect/pr56541.c: Xfail on !vect_cond_mixed targets.

29
gcc/testsuite/gfortran.dg/proc_ptr_comp_46.f90 Normal file
View File

@ -0,0 +1,29 @@
! { dg-do compile }
!
! PR 77596: [F03] procedure pointer component with implicit interface can point to a function
!
! Contributed by toK <t.kondic@leeds.ac.uk>
program xxx
implicit none
type tf
procedure(), nopass, pointer :: fp
end type tf
call ass()
contains
integer function ff(x)
integer, intent(in) :: x
ff = x + 1
end function ff
subroutine ass()
type(tf) :: p
p%fp=>ff ! { dg-error "is not a subroutine" }
call p%fp(3)
end subroutine ass
end