re PR fortran/45521 ([F08] GENERIC resolution with ALLOCATABLE/POINTER and PROCEDURE)

2012-10-06  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/45521
	* interface.c (generic_correspondence): Implement additional
	distinguishability criteria of F08.
	(compare_actual_formal): Reject data object as actual argument for
	procedure formal argument.

2012-10-06  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/45521
	* gfortran.dg/generic_25.f90: New.
	* gfortran.dg/generic_26.f90: New.
	* gfortran.dg/generic_27.f90: New.

From-SVN: r192157

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index a861601e0c2957b48f0d7ac4c36c6d7cc89de056..c8f5c2bb9c46a38c26b5e3a0b72c9d67d4e2cd03 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2012-10-06  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/45521
+       * interface.c (generic_correspondence): Implement additional
+       distinguishability criteria of F08.
+       (compare_actual_formal): Reject data object as actual argument for
+       procedure formal argument.
+
 2012-10-04  Tobias Burnus  <burnus@net-b.de>
 
        * expr.c (scalarize_intrinsic_call): Plug memory leak.

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index fb3da1fb7baa88100d2e8004aa2ec50db9422ebd..4822149cc0bdf06f24e21b9706fc9c4a575e0f47 100644 (file)
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -932,9 +932,9 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
 }
 
 
-/* Perform the correspondence test in rule 3 of section F03:16.2.3.
-   Returns zero if no argument is found that satisfies rule 3, nonzero
-   otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
+/* Perform the correspondence test in rule (3) of F08:C1215.
+   Returns zero if no argument is found that satisfies this rule,
+   nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
    (if applicable).
 
    This test is also not symmetric in f1 and f2 and must be called
@@ -942,13 +942,13 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
    argument list with keywords.  For example:
 
    INTERFACE FOO
-       SUBROUTINE F1(A, B)
-          INTEGER :: A ; REAL :: B
-       END SUBROUTINE F1
+     SUBROUTINE F1(A, B)
+       INTEGER :: A ; REAL :: B
+     END SUBROUTINE F1
 
-       SUBROUTINE F2(B, A)
-          INTEGER :: A ; REAL :: B
-       END SUBROUTINE F1
+     SUBROUTINE F2(B, A)
+       INTEGER :: A ; REAL :: B
+     END SUBROUTINE F1
    END INTERFACE FOO
 
    At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous.  */
@@ -973,7 +973,10 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
        f2 = f2->next;
 
       if (f2 != NULL && (compare_type_rank (f1->sym, f2->sym)
-                        || compare_type_rank (f2->sym, f1->sym)))
+                        || compare_type_rank (f2->sym, f1->sym))
+         && !((gfc_option.allow_std & GFC_STD_F2008)
+              && ((f1->sym->attr.allocatable && f2->sym->attr.pointer)
+                  || (f2->sym->attr.allocatable && f1->sym->attr.pointer))))
        goto next;
 
       /* Now search for a disambiguating keyword argument starting at
@@ -984,7 +987,10 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
            continue;
 
          sym = find_keyword_arg (g->sym->name, f2_save);
-         if (sym == NULL || !compare_type_rank (g->sym, sym))
+         if (sym == NULL || !compare_type_rank (g->sym, sym)
+             || ((gfc_option.allow_std & GFC_STD_F2008)
+                 && ((sym->attr.allocatable && g->sym->attr.pointer)
+                     || (sym->attr.pointer && g->sym->attr.allocatable))))
            return 1;
        }
 
@@ -2551,8 +2557,8 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 
      skip_size_check:
 
-      /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
-        is provided for a procedure pointer formal argument.  */
+      /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
+         argument is provided for a procedure pointer formal argument.  */
       if (f->sym->attr.proc_pointer
          && !((a->expr->expr_type == EXPR_VARIABLE
                && a->expr->symtree->n.sym->attr.proc_pointer)
@@ -2566,11 +2572,10 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
          return 0;
        }
 
-      /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
+      /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
         provided for a procedure formal argument.  */
-      if (a->expr->ts.type != BT_PROCEDURE && !gfc_is_proc_ptr_comp (a->expr)
-         && a->expr->expr_type == EXPR_VARIABLE
-         && f->sym->attr.flavor == FL_PROCEDURE)
+      if (f->sym->attr.flavor == FL_PROCEDURE
+         && gfc_expr_attr (a->expr).flavor != FL_PROCEDURE)
        {
          if (where)
            gfc_error ("Expected a procedure for argument '%s' at %L",

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 67f7387bbf29bdbaf4fb3bb7302f8e5dd44ee315..57580b571b88a3c3811e42189cfad98e1d9555c2 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2012-10-06  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/45521
+       * gfortran.dg/generic_25.f90: New.
+       * gfortran.dg/generic_26.f90: New.
+       * gfortran.dg/generic_27.f90: New.
+
 2012-10-06  Oleg Endo  <olegendo@gcc.gnu.org>
 
        PR target/54760

diff --git a/gcc/testsuite/gfortran.dg/generic_25.f90 b/gcc/testsuite/gfortran.dg/generic_25.f90
new file mode 100644 (file)
index 0000000..39b7e23
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/generic_25.f90
@@ -0,0 +1,30 @@
+! { dg-do run }
+!
+! PR 45521: [F08] GENERIC resolution with ALLOCATABLE/POINTER and PROCEDURE
+!
+! Contributed by <wangmianzhi1@linuxmail.org>
+
+  interface test
+    procedure testAlloc
+    procedure testPtr
+  end interface
+
+  integer, allocatable :: a1
+  integer, pointer :: a2
+
+  if (.not.test(a1)) call abort()
+  if (test(a2)) call abort()
+  
+contains
+
+  logical function testAlloc(obj)
+    integer, allocatable :: obj
+    testAlloc = .true.
+  end function
+  
+  logical function testPtr(obj)
+    integer, pointer :: obj
+    testPtr = .false.
+  end function
+  
+end

diff --git a/gcc/testsuite/gfortran.dg/generic_26.f90 b/gcc/testsuite/gfortran.dg/generic_26.f90
new file mode 100644 (file)
index 0000000..a1deef1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/generic_26.f90
@@ -0,0 +1,29 @@
+! { dg-do compile }
+! { dg-options "-std=f2003" }
+!
+! PR 45521: [F08] GENERIC resolution with ALLOCATABLE/POINTER and PROCEDURE
+!
+! Contributed by <wangmianzhi1@linuxmail.org>
+
+module a
+
+  interface test
+    procedure testAlloc
+    procedure testPtr   ! { dg-error "Ambiguous interfaces" }
+  end interface
+
+contains
+
+  logical function testAlloc(obj)
+    integer, allocatable :: obj
+    testAlloc = .true.
+  end function
+  
+  logical function testPtr(obj)
+    integer, pointer :: obj
+    testPtr = .false.
+  end function
+  
+end
+
+! { dg-final { cleanup-modules "a" } }

diff --git a/gcc/testsuite/gfortran.dg/generic_27.f90 b/gcc/testsuite/gfortran.dg/generic_27.f90
new file mode 100644 (file)
index 0000000..f4f4f5a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/generic_27.f90
@@ -0,0 +1,34 @@
+! { dg-do run }
+!
+! PR 45521: [F08] GENERIC resolution with ALLOCATABLE/POINTER and PROCEDURE
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+module m
+  implicit none
+  interface testIF
+    module procedure test1
+    module procedure test2
+  end interface
+contains
+  real function test1 (obj)
+    real :: obj
+    test1 = obj
+  end function
+  real function test2 (pr)
+    procedure(real) :: pr
+    test2 = pr(0.)
+  end function
+end module
+
+program test
+  use m
+  implicit none
+  intrinsic :: cos
+
+  if (testIF(2.0)/=2.0) call abort()
+  if (testIF(cos)/=1.0) call abort()
+
+end program
+
+! { dg-final { cleanup-modules "m" } }