re PR fortran/54286 (Accepts invalid proc-pointer assignments involving proc-ptr...

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index c1e27634306ae2f49c53a34ff4fa2328b9aef7b1..92b8083dfce114446933f76be2a19bcf54c336e2 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/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

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 89ec1c5f82727e6e7250f3e794dec39ddc3a1700..3010dd9e456972defb51b0059a05b66c5299fee6 100644 (file)
--- a/gcc/fortran/expr.c
+++ b/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 (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 (s1 && s2 && !gfc_compare_interfaces (s1, s2, name, 0, 1,
-                                              err, sizeof(err), NULL, NULL))
+      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);

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 37de4ba527cf45f06a3d08cd3124c91fbd2088ac..67671a86eca419a81dd023462ee8d0b5868b703f 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/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.

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_result_8.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_result_8.f90
new file mode 100644 (file)
index 0000000..de6f39f
--- /dev/null
+++ b/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