gcc/testsuite/gfortran.dg/class_27.f03

   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
   8 module type2_type
   9  implicit none
  10  type, abstract :: Type2
  11  end type Type2
  12 end module type2_type
  13
  14 module 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
  41 end module extended2A_type
  42
  43 module 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
  65 end module type1_type