re PR fortran/54286 (Accepts invalid proc-pointer assignments involving proc-ptr function result)

2013-01-13  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-13  Paul Thomas  <pault@gcc.gnu.org>

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

From-SVN: r195133

gcc/fortran/ChangeLog

@@ -1,3 +1,13 @@
+2013-01-13  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  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/55072

gcc/fortran/expr.c

@@ -3506,7 +3506,11 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
       if (comp)
 	s1 = comp->ts.interface;
       else
-	s1 = lvalue->symtree->n.sym;
+	{
+	  s1 = lvalue->symtree->n.sym;
+	  if (s1->ts.interface)
+	    s1 = s1->ts.interface;
+	}
 
       comp = gfc_get_proc_ptr_comp (rvalue);
       if (comp)
@@ -3514,7 +3518,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
 	  if (rvalue->expr_type == EXPR_FUNCTION)
 	    {
 	      s2 = comp->ts.interface->result;
-	      name = comp->ts.interface->result->name;
+	      name = s2->name;
 	    }
 	  else
 	    {
@@ -3525,16 +3529,30 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
       else if (rvalue->expr_type == EXPR_FUNCTION)
 	{
 	  s2 = rvalue->symtree->n.sym->result;
-	  name = rvalue->symtree->n.sym->result->name;
+	  name = s2->name;
 	}
       else
 	{
 	  s2 = rvalue->symtree->n.sym;
-	  name = rvalue->symtree->n.sym->name;
+	  name = s2->name;
 	}
 
-      if (s1 && s2 && !gfc_compare_interfaces (s1, s2, name, 0, 1,
-					       err, sizeof(err), NULL, NULL))
+      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);

gcc/testsuite/ChangeLog

@@ -1,3 +1,8 @@
+2013-01-13  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/54286
+	* gfortran.dg/proc_ptr_result_8.f90 : New test.
+
 2013-01-13  Richard Sandiford  <rdsandiford@googlemail.com>
 
 	* gcc.dg/unroll_5.c: Add nomips16 attributes.

gcc/testsuite/gfortran.dg/proc_ptr_result_8.f90

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