re PR fortran/56261 ([OOP] seg fault call procedure pointer on polymorphic array)

2013-04-12  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/56261
	* gfortran.h (gfc_explicit_interface_required): New prototype.
	* expr.c (gfc_check_pointer_assign): Check if an explicit interface is
	required in a proc-ptr assignment.
	* interface.c (check_result_characteristics): Extra check.
	* resolve.c (gfc_explicit_interface_required): New function.
	(resolve_global_procedure): Use new function
	'gfc_explicit_interface_required'. Do a full interface check.


2013-04-12  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/56261
	* gfortran.dg/auto_char_len_4.f90: Add -pedantic. Changed error.
	* gfortran.dg/assumed_rank_4.f90: Modified error wording.
	* gfortran.dg/block_11.f90: Fix invalid test case.
	* gfortran.dg/function_types_3.f90: Add new error message.
	* gfortran.dg/global_references_1.f90: Ditto.
	* gfortran.dg/import2.f90: Remove unneeded parts.
	* gfortran.dg/import6.f90: Fix invalid test case.
	* gfortran.dg/proc_decl_2.f90: Ditto.
	* gfortran.dg/proc_decl_9.f90: Ditto.
	* gfortran.dg/proc_decl_18.f90: Ditto.
	* gfortran.dg/proc_ptr_40.f90: New.
	* gfortran.dg/whole_file_7.f90: Modified error wording.
	* gfortran.dg/whole_file_16.f90: Ditto.
	* gfortran.dg/whole_file_17.f90: Add -pedantic.
	* gfortran.dg/whole_file_18.f90: Modified error wording.
	* gfortran.dg/whole_file_20.f03: Ditto.
	* gfortran.fortran-torture/execute/intrinsic_associated.f90: Fix
	invalid test case.

From-SVN: r197922

gcc/fortran/ChangeLog

+2013-04-12  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/56261
+	* gfortran.h (gfc_explicit_interface_required): New prototype.
+	* expr.c (gfc_check_pointer_assign): Check if an explicit interface is
+	required in a proc-ptr assignment.
+	* interface.c (check_result_characteristics): Extra check.
+	* resolve.c (gfc_explicit_interface_required): New function.
+	(resolve_global_procedure): Use new function
+	'gfc_explicit_interface_required'. Do a full interface check.
+
 2013-04-12  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/56845

gcc/fortran/expr.c

@@ -3556,6 +3556,22 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
       if (s1 == s2 || !s1 || !s2)
 	return true;
 
+      /* F08:7.2.2.4 (4)  */
+      if (s1->attr.if_source == IFSRC_UNKNOWN
+	  && gfc_explicit_interface_required (s2, err, sizeof(err)))
+	{
+	  gfc_error ("Explicit interface required for '%s' at %L: %s",
+		     s1->name, &lvalue->where, err);
+	  return false;
+	}
+      if (s2->attr.if_source == IFSRC_UNKNOWN
+	  && gfc_explicit_interface_required (s1, err, sizeof(err)))
+	{
+	  gfc_error ("Explicit interface required for '%s' at %L: %s",
+		     s2->name, &rvalue->where, err);
+	  return false;
+	}
+
       if (!gfc_compare_interfaces (s1, s2, name, 0, 1,
 				   err, sizeof(err), NULL, NULL))
 	{

gcc/fortran/gfortran.h

@@ -2843,6 +2843,7 @@ match gfc_iso_c_sub_interface(gfc_code *, gfc_symbol *);
 gfc_expr *gfc_expr_to_initialize (gfc_expr *);
 bool gfc_type_is_extensible (gfc_symbol *);
 bool gfc_resolve_intrinsic (gfc_symbol *, locus *);
+bool gfc_explicit_interface_required (gfc_symbol *, char *, int);
 
 
 /* array.c */

gcc/fortran/interface.c

@@ -1239,7 +1239,7 @@ check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
 	  return false;
 	}
 
-      if (r1->ts.u.cl->length)
+      if (r1->ts.u.cl->length && r2->ts.u.cl->length)
 	{
 	  int compval = gfc_dep_compare_expr (r1->ts.u.cl->length,
 					      r2->ts.u.cl->length);

gcc/testsuite/ChangeLog

+2013-04-12  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/56261
+	* gfortran.dg/auto_char_len_4.f90: Add -pedantic. Changed error.
+	* gfortran.dg/assumed_rank_4.f90: Modified error wording.
+	* gfortran.dg/block_11.f90: Fix invalid test case.
+	* gfortran.dg/function_types_3.f90: Add new error message.
+	* gfortran.dg/global_references_1.f90: Ditto.
+	* gfortran.dg/import2.f90: Remove unneeded parts.
+	* gfortran.dg/import6.f90: Fix invalid test case.
+	* gfortran.dg/proc_decl_2.f90: Ditto.
+	* gfortran.dg/proc_decl_9.f90: Ditto.
+	* gfortran.dg/proc_decl_18.f90: Ditto.
+	* gfortran.dg/proc_ptr_40.f90: New.
+	* gfortran.dg/whole_file_7.f90: Modified error wording.
+	* gfortran.dg/whole_file_16.f90: Ditto.
+	* gfortran.dg/whole_file_17.f90: Add -pedantic.
+	* gfortran.dg/whole_file_18.f90: Modified error wording.
+	* gfortran.dg/whole_file_20.f03: Ditto.
+	* gfortran.fortran-torture/execute/intrinsic_associated.f90: Fix
+	invalid test case.
+
 2013-04-12  Richard Biener  <rguenther@suse.de>
 
 	Revert

gcc/testsuite/gfortran.dg/assumed_rank_4.f90

@@ -20,8 +20,8 @@ end subroutine valid2
 
 subroutine foo99(x)
   integer  x(99)
-  call valid1(x) ! { dg-error "Procedure 'valid1' at .1. with assumed-rank dummy argument 'x' must have an explicit interface" }
-  call valid2(x(1)) ! { dg-error "Procedure 'valid2' at .1. with assumed-type dummy argument 'x' must have an explicit interface" }
+  call valid1(x) ! { dg-error "Explicit interface required" }
+  call valid2(x(1)) ! { dg-error "Explicit interface required" }
 end subroutine foo99
 
 subroutine foo(x)

gcc/testsuite/gfortran.dg/auto_char_len_4.f90

 ! { dg-do compile }
-! { dg-options "-fwhole-file" }
+! { dg-options "-pedantic -fwhole-file" }
 !
 ! Tests the fix for PR25087, in which the following invalid code
 ! was not detected.
@@ -14,8 +14,8 @@ FUNCTION a()
 END FUNCTION a
 
 SUBROUTINE s(n)
-  CHARACTER(LEN=n), EXTERNAL :: a ! { dg-error "must have an explicit interface" }
-  CHARACTER(LEN=n), EXTERNAL :: d ! { dg-error "must have an explicit interface" }
+  CHARACTER(LEN=n), EXTERNAL :: a  ! { dg-error "Character length mismatch" }
+  CHARACTER(LEN=n), EXTERNAL :: d  ! { dg-error "Character length mismatch" }
   interface
     function b (m)                ! This is OK
       CHARACTER(LEN=m) :: b

gcc/testsuite/gfortran.dg/block_11.f90

@@ -50,7 +50,7 @@ module m3
   implicit none
 contains
   subroutine my_test()
-    procedure(), pointer :: ptr
+    procedure(sub), pointer :: ptr
     ! Before the fix, one had the link error
     ! "undefined reference to `sub.1909'"
     block

gcc/testsuite/gfortran.dg/function_types_3.f90

@@ -5,7 +5,7 @@
 ! PR 50401: SIGSEGV in resolve_transfer
 
   interface 
-    function f()      ! { dg-error "must be a dummy argument" }
+    function f()      ! { dg-error "must be a dummy argument|Interface mismatch in global procedure" }
       dimension f(*)
     end function
   end interface

gcc/testsuite/gfortran.dg/global_references_1.f90

@@ -23,7 +23,7 @@ function g(x)       ! Global entity
 ! Function 'f' cannot be referenced as a subroutine. The previous
 ! definition is in 'line 12'.
 
-  call f(g) ! { dg-error "is already being used as a FUNCTION" }
+  call f(g) ! { dg-error "is already being used as a FUNCTION|Interface mismatch in global procedure" }
 end function g
 ! Error only appears once but testsuite associates with both lines.
 function h(x)       ! { dg-error "is already being used as a FUNCTION" }
@@ -59,7 +59,7 @@ END SUBROUTINE TT
 ! Function 'h' cannot be referenced as a subroutine. The previous
 ! definition is in 'line 29'.
 
-  call h (x) ! { dg-error "is already being used as a FUNCTION" }
+  call h (x) ! { dg-error "is already being used as a FUNCTION|Interface mismatch in global procedure" }
 
 ! PR23308===========================================================
 ! Lahey - 2521-S: "SOURCE.F90", line 68: Intrinsic procedure name or

gcc/testsuite/gfortran.dg/import2.f90

@@ -4,30 +4,6 @@
 ! Test whether import does not work with -std=f95
 ! PR fortran/29601
 
-subroutine test(x)
-  type myType3
-    sequence
-    integer :: i
-  end type myType3
-  type(myType3) :: x
-  if(x%i /= 7) call abort()
-  x%i = 1
-end subroutine test
-
-
-subroutine bar(x,y)
-  type myType
-    sequence
-    integer :: i
-  end type myType
-  type(myType) :: x
-  integer(8) :: y
-  if(y /= 8) call abort()
-  if(x%i /= 2) call abort()
-  x%i = 5
-  y   = 42
-end subroutine bar
-
 module testmod
   implicit none
   integer, parameter :: kind = 8
@@ -66,14 +42,4 @@ program foo
     end subroutine test
   end interface
 
-  type(myType) :: y
-  type(myType3) :: z
-  integer(dp) :: i8
-  y%i = 2
-  i8 = 8
-  call bar(y,i8) ! { dg-error "Type mismatch in argument" }
-  if(y%i /= 5 .or. i8/= 42) call abort()
-  z%i = 7
-  call test(z) ! { dg-error "Type mismatch in argument" }
-  if(z%i /= 1) call abort()
 end program foo

gcc/testsuite/gfortran.dg/import6.f90

@@ -7,6 +7,7 @@
 !
 subroutine func1(param)
   type :: my_type
+    sequence
     integer :: data
   end type my_type
   type(my_type) :: param
@@ -15,6 +16,7 @@ end subroutine func1
 
 subroutine func2(param)
   type :: my_type
+    sequence
     integer :: data
   end type my_type
   type(my_type) :: param
@@ -22,6 +24,7 @@ subroutine func2(param)
 end subroutine func2
 
   type :: my_type
+    sequence
     integer :: data
   end type my_type
 

gcc/testsuite/gfortran.dg/proc_decl_18.f90

@@ -23,7 +23,7 @@ implicit none
 
 abstract interface
   function abs_fun(x,sz)
-    integer :: x(:)
+    integer,intent(in) :: x(:)
     interface
       pure integer function sz(b)
         integer,intent(in) :: b(:)

gcc/testsuite/gfortran.dg/proc_decl_2.f90

@@ -124,12 +124,12 @@ integer function p2(x)
 end function
 
 subroutine p3(x)
-  real,intent(inout):: x
+  real :: x
   x=x+1.0
 end subroutine
 
 subroutine p4(x)
-  real,intent(inout):: x
+  real :: x
   x=x-1.5
 end subroutine
 
@@ -137,7 +137,7 @@ subroutine p5()
 end subroutine
 
 subroutine p6(x)
-  real,intent(inout):: x
+  real :: x
   x=x*2.
 end subroutine
 

gcc/testsuite/gfortran.dg/proc_decl_9.f90

@@ -2,7 +2,7 @@
 ! PR33162 INTRINSIC functions as ACTUAL argument
 ! Test case adapted from PR by Jerry DeLisle <jvdelisle@gcc.gnu.org>
 real function t(x)
-  real ::x
+  real, intent(in) ::x
   t = x
 end function
 

gcc/testsuite/gfortran.dg/proc_ptr_40.f90

+! { dg-do compile }
+!
+! PR 56261: [OOP] seg fault call procedure pointer on polymorphic array
+!
+! Contributed by Andrew Benson <abensonca@gmail.com>
+
+  implicit none
+  type :: nc
+  end type
+  external :: qq
+  procedure(  ), pointer :: f1
+  procedure(ff), pointer :: f2
+  
+  f1 => ff  ! { dg-error "Explicit interface required" }
+  f2 => qq  ! { dg-error "Explicit interface required" }
+
+contains
+
+  subroutine ff (self)
+    class(nc) :: self
+  end subroutine
+
+end

gcc/testsuite/gfortran.dg/whole_file_16.f90

@@ -5,7 +5,7 @@
 !
 program main
   real, dimension(2) :: a
-  call foo(a)                ! { dg-error "must have an explicit interface" }
+  call foo(a)                ! { dg-error "Explicit interface required" }
 end program main
 
 subroutine foo(a)

gcc/testsuite/gfortran.dg/whole_file_17.f90

 ! { dg-do compile }
-! { dg-options "-fwhole-file" }
+! { dg-options "-pedantic -fwhole-file" }
 !
 ! PR fortran/30668
 !

gcc/testsuite/gfortran.dg/whole_file_18.f90

@@ -5,7 +5,7 @@
 !
       PROGRAM MAIN
       REAL A
-      CALL SUB(A)             ! { dg-error "requires an explicit interface" }
+      CALL SUB(A)             ! { dg-error "Explicit interface required" }
       END PROGRAM
 
       SUBROUTINE SUB(A,I)

gcc/testsuite/gfortran.dg/whole_file_20.f03

@@ -17,8 +17,8 @@ PROGRAM main
 
   INTEGER :: coarr[*]
 
-  CALL coarray(coarr)         ! { dg-error " must have an explicit interface" }
-  CALL polymorph(tt)          ! { dg-error " must have an explicit interface" }
+  CALL coarray(coarr)         ! { dg-error "Explicit interface required" }
+  CALL polymorph(tt)          ! { dg-error "Explicit interface required" }
 END PROGRAM
 
 SUBROUTINE coarray(a)

gcc/testsuite/gfortran.dg/whole_file_7.f90

@@ -29,6 +29,6 @@ end function test
 
 program arr     ! The error was not picked up causing an ICE
   real, dimension(2) :: res
-  res = test(2) ! { dg-error "needs an explicit INTERFACE" }
+  res = test(2) ! { dg-error "Explicit interface required" }
   print *, res
 end program

gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_associated.f90

@@ -121,7 +121,7 @@ subroutine associated_2 ()
    interface
       subroutine sub1 (a, ap)
          integer, pointer :: ap(:, :)
-         integer, target  :: a(10, 1)
+         integer, target  :: a(10, 10)
       end
    endinterface