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