3 ! Test that PR69298 is fixed. Used to segfault on finalization in
4 ! subroutine 'in_type'.
6 ! Contributed by Neil Carlson <neil.n.carlson@gmail.com>
11 public :: stuff_type, final_calls
17 procedure stuff_copy_initialiser
18 generic :: assignment(=) => stuff_copy_initialiser
19 final :: stuff_scalar_finaliser, &
22 integer :: final_calls = 0
24 procedure stuff_initialiser
25 end interface stuff_type
28 function stuff_initialiser( junk ) result(new_stuff)
30 type(stuff_type) :: new_stuff
33 end function stuff_initialiser
35 subroutine stuff_copy_initialiser( destination, source )
37 class(stuff_type), intent(out) :: destination
38 class(stuff_type), intent(in) :: source
39 destination%junk = source%junk
40 end subroutine stuff_copy_initialiser
42 subroutine stuff_scalar_finaliser( this )
44 type(stuff_type), intent(inout) :: this
45 final_calls = final_calls + 1
46 end subroutine stuff_scalar_finaliser
48 subroutine stuff_1d_finaliser( this )
50 type(stuff_type), intent(inout) :: this(:)
52 final_calls = final_calls + 100
53 end subroutine stuff_1d_finaliser
55 function get_junk( this ) result(junk)
57 class(stuff_type), intent(in) :: this
64 use stuff_mod, only : stuff_type, final_calls
70 type(stuff_type) :: thing
71 type(stuff_type) :: things(3)
76 procedure test_type_initialiser
77 end interface test_type
80 function test_type_initialiser() result(new_test)
82 type(test_type) :: new_test
83 integer :: i ! At entry: 1 array and 9 scalars
84 new_test%thing = stuff_type( 4 ) ! Gives 2 scalar calls
86 new_test%things(i) = stuff_type( i ) ! Gives 6 scalar calls
88 end function test_type_initialiser
90 function get_value( this ) result(value)
92 class(test_type) :: this
95 value = this%thing%get_junk()
97 value = value + this%things(i)%get_junk()
99 end function get_value
103 use stuff_mod, only : stuff_type, final_calls
104 use test_mod, only : test_type
107 ! One array call and 1 scalar call after leaving scope => 1 + 9 total; NAGFOR and IFORT agree
108 if (final_calls .ne. 109) stop 1
110 ! 21 calls to scalar finalizer and 4 to the vector version; IFORT agrees
111 ! NAGFOR also produces 21 scalar calls but 5 vector calls.
112 if (final_calls .ne. 421) print *, final_calls
117 type(stuff_type) :: thing
118 type(stuff_type) :: bits(3)
121 thing = stuff_type(4) ! Two scalar final calls; INTENT(OUT) and initialiser
123 bits(i) = stuff_type(i) ! ditto times 3
125 tally = thing%get_junk()
127 tally = tally + bits(i)%get_junk()
129 if (tally .ne. 10) stop 3 ! 8 scalar final calls by here
134 type(test_type) :: thing
135 thing = test_type() ! 8 scalar in test_type + 1 vector and 1 scalar to finalize function result and
136 ! 1 vectors and 2 scalars from the expansion of the defined assignment.
137 if (thing%get_value() .ne. 10) stop 4
138 end subroutine in_type