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

re PR fortran/80046 ([F03] Explicit interface required: pointer argument)

Browse Source 
2017-04-10  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/80046
	* expr.c (gfc_check_pointer_assign): Check if procedure pointer
	components in a pointer assignment need an explicit interface.

2017-04-10  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/80046
	* gfortran.dg/proc_ptr_comp_48.f90: New test case.

From-SVN: r246823
This commit is contained in:
Janus Weil 2017-04-10 22:28:23 +02:00
parent 7db31bc20c
commit 99827b5ca0
4 changed files with 90 additions and 16 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 @@
2017-04-10 Janus Weil <janus@gcc.gnu.org>
PR fortran/80046
* expr.c (gfc_check_pointer_assign): Check if procedure pointer
components in a pointer assignment need an explicit interface.
2017-03-18 Nicolas Koenig <koenigni@student.ethz.ch>
PR fortran/69498

48
gcc/fortran/expr.c
View File

@ -3595,25 +3595,41 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
return false;
}
/* F08:7.2.2.4 (4) */
if (s2 && gfc_explicit_interface_required (s2, err, sizeof(err)))
{
if (comp1 && !s1)
{
gfc_error ("Explicit interface required for component %qs at %L: %s",
comp1->name, &lvalue->where, err);
return false;
}
else if (s1->attr.if_source == IFSRC_UNKNOWN)
{
gfc_error ("Explicit interface required for %qs at %L: %s",
s1->name, &lvalue->where, err);
return false;
}
}
if (s1 && gfc_explicit_interface_required (s1, err, sizeof(err)))
{
if (comp2 && !s2)
{
gfc_error ("Explicit interface required for component %qs at %L: %s",
comp2->name, &rvalue->where, err);
return false;
}
else if (s2->attr.if_source == IFSRC_UNKNOWN)
{
gfc_error ("Explicit interface required for %qs at %L: %s",
s2->name, &rvalue->where, err);
return false;
}
}
if (s1 == s2 || !s1 || !s2)
return true;
/* F08:7.2.2.4 (4) */
if (s1->attr.if_source == IFSRC_UNKNOWN
&& gfc_explicit_interface_required (s2, err, sizeof(err)))
{
gfc_error ("Explicit interface required for %qs at %L: %s",
s1->name, &lvalue->where, err);
return false;
}
if (s2->attr.if_source == IFSRC_UNKNOWN
&& gfc_explicit_interface_required (s1, err, sizeof(err)))
{
gfc_error ("Explicit interface required for %qs at %L: %s",
s2->name, &rvalue->where, err);
return false;
}
if (!gfc_compare_interfaces (s1, s2, name, 0, 1,
err, sizeof(err), NULL, NULL))
{

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2017-04-10 Janus Weil <janus@gcc.gnu.org>
PR fortran/80046
* gfortran.dg/proc_ptr_comp_48.f90: New test case.
2017-04-10 David Edelsohn <dje.gcc@gmail.com>
* g++.dg/torture/pr79905.C: Add -maltivec option.

47
gcc/testsuite/gfortran.dg/proc_ptr_comp_48.f90 Normal file
View File

@ -0,0 +1,47 @@
! { dg-do compile }
!
! PR 80046: [F03] Explicit interface required: pointer argument
!
! Contributed by Joachim Herb <joachim.herb@gmx.de>
program p
implicit none
type :: Node_t
procedure(NodeCloner), nopass, pointer :: cloneProc => NULL()
procedure(), nopass, pointer :: noIfc => NULL()
end type
interface
subroutine NodeCloner( tgt, src )
import Node_t
type(Node_t), pointer, intent(out) :: tgt
type(Node_t), intent(in) :: src
end subroutine
end interface
type(Node_t) :: node
procedure(NodeCloner), pointer :: cloneNode
procedure(), pointer :: noIfc
cloneNode => node%noIfc ! { dg-error "Explicit interface required" }
node%noIfc => cloneNode ! { dg-error "Explicit interface required" }
noIfc => node%cloneProc ! { dg-error "Explicit interface required" }
node%cloneProc => noIfc ! { dg-error "Explicit interface required" }
node%cloneProc => node%noIfc ! { dg-error "Explicit interface required" }
node%noIfc => node%cloneProc ! { dg-error "Explicit interface required" }
! the following cases are legal
node%noIfc => node%noIfc
node%cloneProc => node%cloneProc
cloneNode => node%cloneProc
node%cloneProc => cloneNode
noIfc => node%noIfc
node%noIfc => noIfc
end