Re: [Patch,Fortran] Copy more attributes for PROCEDURE() (PR35830)

[Tobias Burnus <tobias dot burnus at physik dot fu-berlin dot de>]

Francois-Xaver wrote:
> Patch seems quite trivial, but I would be completely unable to say if
> you missed one or more :) So, once you and Janus agree on the list of
> attributes to copy, it's OK to commit.
Thanks.

Janus Weil wrote:
> Nice. Thanks for looking into this. The only thing that I think you
> might have missed is ALLOCATABLE.
Thanks for pointing out!

I now also copy allocatable and added the test case.

Committed as Rev. 136554.

Thanks for the review!

Tobias

Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(Revision 136553)
+++ gcc/fortran/resolve.c	(Arbeitskopie)
@@ -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')
Index: gcc/testsuite/gfortran.dg/proc_decl_13.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_decl_13.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/proc_decl_13.f90	(Revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/proc_decl_14.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_decl_14.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/proc_decl_14.f90	(Revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/proc_decl_15.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_decl_15.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/proc_decl_15.f90	(Revision 0)
@@ -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