From 73865312272b9900466e8a3223e340d028550dab Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Fri, 16 Feb 2007 10:55:20 +0100 Subject: [PATCH] re PR fortran/30793 (Segfault on calling a function returning a pointer) fortran/ 2007-02-16 Tobias Burnus PR fortran/30793 * trans-decl.c (gfc_generate_function_code): Do not initialize pointers to derived components. testsuite/ 2007-02-16 Tobias Burnus PR fortran/30793 * gfortran.dg/func_derived_4.f90: New test. From-SVN: r122037 --- gcc/fortran/ChangeLog | 6 ++ gcc/fortran/trans-decl.c | 3 +- gcc/testsuite/ChangeLog | 5 + gcc/testsuite/gfortran.dg/func_derived_4.f90 | 105 +++++++++++++++++++ 4 files changed, 118 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gfortran.dg/func_derived_4.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 796c8b9a06b..02ba34f881b 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2007-02-16 Tobias Burnus + + PR fortran/30793 + * trans-decl.c (gfc_generate_function_code): Do not initialize + pointers to derived components. + 2007-02-15 Sandra Loosemore Brooks Moses Lee Millward diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index d001ad9eba6..019fbd6bdc2 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -3240,7 +3240,8 @@ gfc_generate_function_code (gfc_namespace * ns) if (result != NULL_TREE && sym->attr.function && sym->ts.type == BT_DERIVED - && sym->ts.derived->attr.alloc_comp) + && sym->ts.derived->attr.alloc_comp + && !sym->attr.pointer) { rank = sym->as ? sym->as->rank : 0; tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 56519172654..7db30065a9e 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2007-02-16 Tobias Burnus + + PR fortran/30793 + * gfortran.dg/func_derived_4.f90: New test. + 2007-02-15 Roger Sayle PR middle-end/30391 diff --git a/gcc/testsuite/gfortran.dg/func_derived_4.f90 b/gcc/testsuite/gfortran.dg/func_derived_4.f90 new file mode 100644 index 00000000000..86be8d4ead2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/func_derived_4.f90 @@ -0,0 +1,105 @@ +! { dg-do run } +! PR fortran/30793 +! Check that pointer-returing functions +! work derived types. +! +! Contributed by Salvatore Filippone. +! +module class_mesh + type mesh + real(kind(1.d0)), allocatable :: area(:) + end type mesh +contains + subroutine create_mesh(msh) + type(mesh), intent(out) :: msh + allocate(msh%area(10)) + return + end subroutine create_mesh +end module class_mesh + +module class_field + use class_mesh + implicit none + private ! Default + public :: create_field, field + public :: msh_ + + type field + private + type(mesh), pointer :: msh => null() + integer :: isize(2) + end type field + + interface msh_ + module procedure msh_ + end interface + interface create_field + module procedure create_field + end interface +contains + subroutine create_field(fld,msh) + type(field), intent(out) :: fld + type(mesh), intent(in), target :: msh + fld%msh => msh + fld%isize = 1 + end subroutine create_field + + function msh_(fld) + type(mesh), pointer :: msh_ + type(field), intent(in) :: fld + msh_ => fld%msh + end function msh_ +end module class_field + +module class_scalar_field + use class_field + implicit none + private + public :: create_field, scalar_field + public :: msh_ + + type scalar_field + private + type(field) :: base + real(kind(1.d0)), allocatable :: x(:) + real(kind(1.d0)), allocatable :: bx(:) + real(kind(1.d0)), allocatable :: x_old(:) + end type scalar_field + + interface create_field + module procedure create_scalar_field + end interface + interface msh_ + module procedure get_scalar_field_msh + end interface +contains + subroutine create_scalar_field(fld,msh) + use class_mesh + type(scalar_field), intent(out) :: fld + type(mesh), intent(in), target :: msh + call create_field(fld%base,msh) + allocate(fld%x(10),fld%bx(20)) + end subroutine create_scalar_field + + function get_scalar_field_msh(fld) + use class_mesh + type(mesh), pointer :: get_scalar_field_msh + type(scalar_field), intent(in), target :: fld + + get_scalar_field_msh => msh_(fld%base) + end function get_scalar_field_msh +end module class_scalar_field + +program test_pnt + use class_mesh + use class_scalar_field + implicit none + type(mesh) :: msh + type(mesh), pointer :: mshp + type(scalar_field) :: quality + call create_mesh(msh) + call create_field(quality,msh) + mshp => msh_(quality) +end program test_pnt + +! { dg-final { cleanup-modules "class_mesh class_scalar_field class_mesh" } }