re PR fortran/35830 (ICE with PROCEDURE(<interface>) containing array formal arguments)

2008-06-08  Tobias Burnus  <burnus@net-b.de>

       PR fortran/35830
       * resolve.c (resolve_symbol): Copy more attributes for
       PROCEDUREs with interfaces.

2008-06-08  Tobias Burnus  <burnus@net-b.de>

       PR fortran/35830
       * proc_decl_13.f90: New.
       * proc_decl_14.f90: New.
       * proc_decl_15.f90: New.

From-SVN: r136554

gcc/fortran/ChangeLog

@@ -1,3 +1,9 @@
+2008-06-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/35830
+	* resolve.c (resolve_symbol): Copy more attributes for
+	PROCEDUREs with interfaces.
+
 2008-06-07  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR fortran/36420

gcc/fortran/resolve.c

@@ -7905,6 +7905,14 @@ resolve_symbol (gfc_symbol *sym)
 	  sym->ts.interface = ifc;
 	  sym->attr.function = ifc->attr.function;
 	  sym->attr.subroutine = ifc->attr.subroutine;
+	  sym->attr.allocatable = ifc->attr.allocatable;
+	  sym->attr.pointer = ifc->attr.pointer;
+	  sym->attr.pure = ifc->attr.pure;
+	  sym->attr.elemental = ifc->attr.elemental;
+	  sym->attr.dimension = ifc->attr.dimension;
+	  sym->attr.recursive = ifc->attr.recursive;
+	  sym->attr.always_explicit = ifc->attr.always_explicit;
+	  sym->as = gfc_copy_array_spec (ifc->as);
 	  copy_formal_args (sym, ifc);
 	}
       else if (sym->ts.interface->name[0] != '\0')

gcc/testsuite/ChangeLog

@@ -1,3 +1,10 @@
+2008-06-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/35830
+	* proc_decl_13.f90: New.
+	* proc_decl_14.f90: New.
+	* proc_decl_15.f90: New.
+
 2008-06-07  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR fortran/36420

gcc/testsuite/gfortran.dg/proc_decl_13.f90

@@ -0,0 +1,45 @@
+! { dg-do run }
+! PR fortran/35830
+!
+module m
+contains
+  subroutine one(a)
+      integer a(:)
+      print *, lbound(a), ubound(a), size(a)
+      if ((lbound(a,dim=1) /= 1) .or. (ubound(a,dim=1) /= 3)) &
+        call abort()
+      print *, a
+      if (any(a /= [1,2,3])) call abort()
+  end subroutine one
+end module m
+
+program test
+  use m
+  implicit none
+  call foo1(one)
+  call foo2(one)
+contains
+  subroutine foo1(f)
+    ! The following interface block is needed
+    ! for NAG f95 as it wrongly does not like
+    ! use-associated interfaces for PROCEDURE
+    ! (It is not needed for gfortran)
+    interface
+      subroutine bar(a)
+        integer a(:)
+      end subroutine
+    end interface
+    procedure(bar) :: f
+    call f([1,2,3]) ! Was failing before
+  end subroutine foo1
+  subroutine foo2(f)
+    interface
+      subroutine f(a)
+        integer a(:)
+      end subroutine
+    end interface
+    call f([1,2,3]) ! Works
+  end subroutine foo2
+
+! { dg-final { cleanup-modules "m" } }
+end program test

gcc/testsuite/gfortran.dg/proc_decl_14.f90

@@ -0,0 +1,26 @@
+! { dg-do compile }
+! PR fortran/35830
+!
+abstract interface
+  function ptrfunc()
+    integer, pointer :: ptrfunc
+  end function ptrfunc
+  elemental subroutine elem(a)
+    integer,intent(in) :: a
+  end subroutine elem
+  function dims()
+    integer :: dims(3)
+  end function dims
+end interface
+
+procedure(ptrfunc) :: func_a
+procedure(elem)    :: func_b
+procedure(dims)     :: func_c
+
+integer, pointer :: ptr
+integer :: array(3)
+
+ptr => func_a()
+call func_b([1,2,3])
+array = func_c()
+end

gcc/testsuite/gfortran.dg/proc_decl_15.f90

@@ -0,0 +1,20 @@
+! { dg-do run }
+! PR fortran/35830
+!
+function f()
+  real, allocatable :: f(:)
+  allocate(f(1:3))
+  f(1:3)= (/9,8,7/)
+end function
+
+program test
+  implicit none
+  abstract interface
+    function ai()
+      real, allocatable :: ai(:)
+    end function
+  end interface
+  procedure(ai) :: f
+  if(any(f() /= [9,8,7])) call abort()
+  if(size(f()) /= 3) call abort()
+end