Subversion Repositories openrisc

! { dg-do compile }

!

! PR 46330: [4.6 Regression] [OOP] ICE after revision 166368

!

! Contributed by Dominique d'Humieres 

! 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" } }