public inbox for gcc-patches@gcc.gnu.org
 help / color / mirror / Atom feed
* [Patch, fortran] PR54286 - [4.8 Regression] Accepts invalid proc-pointer assignments involving proc-ptr function result
@ 2013-01-12 11:25 Paul Richard Thomas
  2013-01-12 19:35 ` Janus Weil
  0 siblings, 1 reply; 3+ messages in thread
From: Paul Richard Thomas @ 2013-01-12 11:25 UTC (permalink / raw)
  To: fortran, gcc-patches, Mikael Morin

[-- Attachment #1: Type: text/plain, Size: 1157 bytes --]

Dear All,

It is something of an exaggeration to say that this PR is a regession,
although it is true that gcc-4.7 gives error messages for the testcase
in the correct places.  In fact, these messages disappear if IMPLICIT
INTEGER (a) at the start of the testcase.

The fix ensures that the interfaces are selected and checked
symmetrically in gfc_compare_interfaces.


The submitted testcase only checks the errors.  The other tests in the
testsuite adequately check the functionality of procedure pointer
assignments.

Bootstrapped and regtested on FC17/i86_64 - OK for trunk

Cheers

Paul

2013-01-12  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/54286
    * expr.c (gfc_check_pointer_assign): Ensure that both lvalue
    and rvalue interfaces are presented to gfc_compare_interfaces.
    Simplify references to interface names by using the symbols
    themselves. Call gfc_compare_interfaces with s1 and s2 inter-
    changed to overcome the asymmetry of this function. Do not
    repeat the check for the presence of s1 and s2.

2013-01-12  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/54286
    * gfortran.dg/proc_ptr_result_8.f90 : New test.

[-- Attachment #2: submit.diff --]
[-- Type: application/octet-stream, Size: 3763 bytes --]

Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c	(revision 195123)
--- gcc/fortran/expr.c	(working copy)
*************** gfc_check_pointer_assign (gfc_expr *lval
*** 3506,3512 ****
        if (comp)
  	s1 = comp->ts.interface;
        else
! 	s1 = lvalue->symtree->n.sym;
  
        comp = gfc_get_proc_ptr_comp (rvalue);
        if (comp)
--- 3506,3516 ----
        if (comp)
  	s1 = comp->ts.interface;
        else
! 	{
! 	  s1 = lvalue->symtree->n.sym;
! 	  if (s1->ts.interface)
! 	    s1 = s1->ts.interface;
! 	}
  
        comp = gfc_get_proc_ptr_comp (rvalue);
        if (comp)
*************** gfc_check_pointer_assign (gfc_expr *lval
*** 3514,3520 ****
  	  if (rvalue->expr_type == EXPR_FUNCTION)
  	    {
  	      s2 = comp->ts.interface->result;
! 	      name = comp->ts.interface->result->name;
  	    }
  	  else
  	    {
--- 3518,3524 ----
  	  if (rvalue->expr_type == EXPR_FUNCTION)
  	    {
  	      s2 = comp->ts.interface->result;
! 	      name = s2->name;
  	    }
  	  else
  	    {
*************** gfc_check_pointer_assign (gfc_expr *lval
*** 3525,3540 ****
        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), NULL, NULL))
  	{
  	  gfc_error ("Interface mismatch in procedure pointer assignment "
  		     "at %L: %s", &rvalue->where, err);
--- 3529,3558 ----
        else if (rvalue->expr_type == EXPR_FUNCTION)
  	{
  	  s2 = rvalue->symtree->n.sym->result;
! 	  name = s2->name;
  	}
        else
  	{
  	  s2 = rvalue->symtree->n.sym;
! 	  name = s2->name;
! 	}
! 
!       if (s2->attr.proc_pointer && s2->ts.interface)
! 	s2 = s2->ts.interface;
! 
!       if (s1 == s2 || !s1 || !s2)
! 	return SUCCESS;
! 
!       if (!gfc_compare_interfaces (s1, s2, name, 0, 1,
! 				   err, sizeof(err), NULL, NULL))
! 	{
! 	  gfc_error ("Interface mismatch in procedure pointer assignment "
! 		     "at %L: %s", &rvalue->where, err);
! 	  return FAILURE;
  	}
  
!       if (!gfc_compare_interfaces (s2, s1, name, 0, 1,
! 				   err, sizeof(err), NULL, NULL))
  	{
  	  gfc_error ("Interface mismatch in procedure pointer assignment "
  		     "at %L: %s", &rvalue->where, err);
Index: gcc/testsuite/gfortran.dg/proc_ptr_result_8.f90
===================================================================
*** gcc/testsuite/gfortran.dg/proc_ptr_result_8.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/proc_ptr_result_8.f90	(working copy)
***************
*** 0 ****
--- 1,45 ----
+ ! { dg-do compile }
+ ! Test fix for PR54286.
+ !
+ ! Contributed by Janus Weil  <janus@gcc.gnu.org>
+ !
+ implicit integer (a)
+ type :: t
+   procedure(a), pointer, nopass :: p
+ end type
+ type(t) :: x
+ 
+ procedure(iabs), pointer :: pp
+ procedure(foo), pointer :: pp1
+ 
+ x%p => a     ! ok
+ if (x%p(0) .ne. loc(foo)) call abort
+ if (x%p(1) .ne. loc(iabs)) call abort
+ 
+ x%p => a(1)  ! { dg-error "PROCEDURE POINTER mismatch in function result" }
+ 
+ pp => a(1)   ! ok
+ if (pp(-99) .ne. iabs(-99)) call abort
+ 
+ pp1 => a(2)   ! ok
+ if (pp1(-99) .ne. -iabs(-99)) call abort
+ 
+ pp => a  ! { dg-error "PROCEDURE POINTER mismatch in function result" }
+ 
+ contains
+ 
+   function a (c) result (b)
+     integer, intent(in) :: c
+     procedure(iabs), pointer :: b
+     if (c .eq. 1) then
+       b => iabs
+     else
+       b => foo
+     end if
+   end function
+ 
+   integer function foo (arg)
+     integer, intent (in) :: arg
+     foo = -iabs(arg)
+   end function
+ end

^ permalink raw reply	[flat|nested] 3+ messages in thread
end of thread, other threads:[~2013-01-13  9:07 UTC | newest]

Thread overview: 3+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2013-01-12 11:25 [Patch, fortran] PR54286 - [4.8 Regression] Accepts invalid proc-pointer assignments involving proc-ptr function result Paul Richard Thomas
2013-01-12 19:35 ` Janus Weil
2013-01-13  9:07   ` Paul Richard Thomas

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).