1! { dg-do compile } 2! 3! PR 46330: [4.6 Regression] [OOP] ICE after revision 166368 4! 5! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr> 6! Taken from http://groups.google.com/group/comp.lang.fortran/browse_thread/thread/76f99e7fd4f3e772 7 8module type2_type 9 implicit none 10 type, abstract :: Type2 11 end type Type2 12end module type2_type 13 14module extended2A_type 15 use type2_type 16 implicit none 17 type, extends(Type2) :: Extended2A 18 real(kind(1.0D0)) :: coeff1 = 1. 19 contains 20 procedure :: setCoeff1 => Extended2A_setCoeff1 21 end type Extended2A 22 contains 23 function Extended2A_new(c1, c2) result(typePtr_) 24 real(kind(1.0D0)), optional, intent(in) :: c1 25 real(kind(1.0D0)), optional, intent(in) :: c2 26 type(Extended2A), pointer :: typePtr_ 27 type(Extended2A), save, allocatable, target :: type_ 28 allocate(type_) 29 typePtr_ => null() 30 if (present(c1)) call type_%setCoeff1(c1) 31 typePtr_ => type_ 32 if ( .not.(associated (typePtr_))) then 33 stop 'Error initializing Extended2A Pointer.' 34 endif 35 end function Extended2A_new 36 subroutine Extended2A_setCoeff1(this,c1) 37 class(Extended2A) :: this 38 real(kind(1.0D0)), intent(in) :: c1 39 this% coeff1 = c1 40 end subroutine Extended2A_setCoeff1 41end module extended2A_type 42 43module type1_type 44 use type2_type 45 implicit none 46 type Type1 47 class(type2), pointer :: type2Ptr => null() 48 contains 49 procedure :: initProc => Type1_initProc 50 end type Type1 51 contains 52 function Type1_initProc(this) result(iError) 53 use extended2A_type 54 implicit none 55 class(Type1) :: this 56 integer :: iError 57 this% type2Ptr => extended2A_new() 58 if ( .not.( associated(this% type2Ptr))) then 59 iError = 1 60 write(*,'(A)') "Something Wrong." 61 else 62 iError = 0 63 endif 64 end function Type1_initProc 65end module type1_type 66