re PR fortran/38415 (procedure pointer assignment to abstract interface)

2008-12-06  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/38415
	* expr.c (gfc_check_pointer_assign): Added a check for abstract
	interfaces in procedure pointer assignments, removed check involving
	gfc_compare_interfaces until PR38290 is fixed completely.

2008-12-06  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/38415
	* gfortran.dg/proc_ptr_2.f90: Extended.
	* gfortran.dg/proc_ptr_11.f90: Modified.

From-SVN: r142520

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 5cdbb230293c393f30f4e422f474b4060ecfd491..0fed3d2957075e3759a4930a8842bd4b6ed52571 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2008-12-06  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/38415
+       * expr.c (gfc_check_pointer_assign): Added a check for abstract
+       interfaces in procedure pointer assignments, removed check involving
+       gfc_compare_interfaces until PR38290 is fixed completely.
+
 2008-12-05  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
        PR fortran/38291

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index b94e5ac0b87e00951cd5d3e8b65aadc6e811b6ee..07dfc7a08a31fc953b8dfca9967274c4bfc38469 100644 (file)
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3125,6 +3125,13 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
                     &rvalue->where);
          return FAILURE;
        }
+      if (attr.abstract)
+       {
+         gfc_error ("Abstract interface '%s' is invalid "
+                    "in procedure pointer assignment at %L",
+                    rvalue->symtree->name, &rvalue->where);
+       }
+      /* TODO. See PR 38290.
       if (rvalue->expr_type == EXPR_VARIABLE
          && lvalue->symtree->n.sym->attr.if_source != IFSRC_UNKNOWN
          && !gfc_compare_interfaces (lvalue->symtree->n.sym,
@@ -3133,7 +3140,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
          gfc_error ("Interfaces don't match "
                     "in procedure pointer assignment at %L", &rvalue->where);
          return FAILURE;
-       }
+       }*/
       return SUCCESS;
     }
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 5b26088dd13ee3288bfd916bf13ed9fa9533f755..2c7ee3cba637e9f3ba6897470d27cbfa19769d73 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2008-12-06  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/38415
+       * gfortran.dg/proc_ptr_2.f90: Extended.
+       * gfortran.dg/proc_ptr_11.f90: Modified.
+
 2008-12-05  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
        PR fortran/38291

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_11.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_11.f90
index a5cdbb54890c3e5b387b898de9e246e2605c3da0..69bf140b818c7775a6d3c8749acfd50dce9c0748 100644 (file)
--- a/gcc/testsuite/gfortran.dg/proc_ptr_11.f90
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_11.f90
@@ -14,8 +14,12 @@ program bsp
   end interface
 
   procedure( up ) , pointer :: pptr
+  procedure(isign), pointer :: q
 
-  pptr => add   ! { dg-error "Interfaces don't match" }
+  ! TODO. See PR 38290.
+  !pptr => add   ! { "Interfaces don't match" }
+
+  q => add
 
   print *, pptr()   ! { dg-error "is not a function" }
 

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_2.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_2.f90
index 6224dc5980ba2c86ff6b3e96d3485c48e3df6f71..98539b985af167891a2152650e4f3b55a45683ac 100644 (file)
--- a/gcc/testsuite/gfortran.dg/proc_ptr_2.f90
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_2.f90
@@ -8,10 +8,18 @@ PROCEDURE(REAL), POINTER :: ptr
 PROCEDURE(REAL), SAVE    :: noptr    ! { dg-error "attribute conflicts with" }
 REAL :: x
 
+ abstract interface
+   subroutine bar(a)
+     integer :: a
+   end subroutine bar
+ end interface
+
 ptr => cos(4.0)        ! { dg-error "Invalid procedure pointer assignment" }
 ptr => x               ! { dg-error "Invalid procedure pointer assignment" }
 ptr => sin(x)          ! { dg-error "Invalid procedure pointer assignment" }
 
+ptr => bar             ! { dg-error "is invalid in procedure pointer assignment" }
+
 ALLOCATE(ptr)          ! { dg-error "must be ALLOCATABLE" }
 
 end