This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [Patch,Fortran] Copy more attributes for PROCEDURE() (PR35830)
- From: Tobias Burnus <tobias dot burnus at physik dot fu-berlin dot de>
- To: fortran at gcc dot gnu dot org, gcc-patches at gcc dot gnu dot org
- Date: Sun, 8 Jun 2008 09:49:16 +0200
- Subject: Re: [Patch,Fortran] Copy more attributes for PROCEDURE() (PR35830)
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