diff options
Diffstat (limited to 'gcc/testsuite/gfortran.dg/class_27.f03')
-rw-r--r-- | gcc/testsuite/gfortran.dg/class_27.f03 | 67 |
1 files changed, 67 insertions, 0 deletions
diff --git a/gcc/testsuite/gfortran.dg/class_27.f03 b/gcc/testsuite/gfortran.dg/class_27.f03 new file mode 100644 index 000000000..c3a3c902e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_27.f03 @@ -0,0 +1,67 @@ +! { dg-do compile } +! +! PR 46330: [4.6 Regression] [OOP] ICE after revision 166368 +! +! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr> +! Taken from http://groups.google.com/group/comp.lang.fortran/browse_thread/thread/76f99e7fd4f3e772 + +module type2_type + implicit none + type, abstract :: Type2 + end type Type2 +end module type2_type + +module extended2A_type + use type2_type + implicit none + type, extends(Type2) :: Extended2A + real(kind(1.0D0)) :: coeff1 = 1. + contains + procedure :: setCoeff1 => Extended2A_setCoeff1 + end type Extended2A + contains + function Extended2A_new(c1, c2) result(typePtr_) + real(kind(1.0D0)), optional, intent(in) :: c1 + real(kind(1.0D0)), optional, intent(in) :: c2 + type(Extended2A), pointer :: typePtr_ + type(Extended2A), save, allocatable, target :: type_ + allocate(type_) + typePtr_ => null() + if (present(c1)) call type_%setCoeff1(c1) + typePtr_ => type_ + if ( .not.(associated (typePtr_))) then + stop 'Error initializing Extended2A Pointer.' + endif + end function Extended2A_new + subroutine Extended2A_setCoeff1(this,c1) + class(Extended2A) :: this + real(kind(1.0D0)), intent(in) :: c1 + this% coeff1 = c1 + end subroutine Extended2A_setCoeff1 +end module extended2A_type + +module type1_type + use type2_type + implicit none + type Type1 + class(type2), pointer :: type2Ptr => null() + contains + procedure :: initProc => Type1_initProc + end type Type1 + contains + function Type1_initProc(this) result(iError) + use extended2A_type + implicit none + class(Type1) :: this + integer :: iError + this% type2Ptr => extended2A_new() + if ( .not.( associated(this% type2Ptr))) then + iError = 1 + write(*,'(A)') "Something Wrong." + else + iError = 0 + endif + end function Type1_initProc +end module type1_type + +! { dg-final { cleanup-modules "type2_type extended2A_type type1_type" } } |