1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
|
! { dg-do run }
! { dg-options "-fno-tree-vrp" }
! PR fortran/89282
! Contributed by Federico Perini.
!
module myclass
use iso_fortran_env, only: real64
implicit none
! My generic type
type :: t
integer :: n=0
real(real64), allocatable :: x(:)
contains
procedure :: init => t_init
procedure :: destroy => t_destroy
procedure :: print => t_print
procedure, private, pass(this) :: x_minus_t
generic :: operator(-) => x_minus_t
end type t
contains
elemental subroutine t_destroy(this)
class(t), intent(inout) :: this
this%n=0
if (allocated(this%x)) deallocate(this%x)
end subroutine t_destroy
subroutine t_init(this,n)
class(t), intent(out) :: this
integer, intent(in) :: n
call this%destroy()
this%n=n
allocate(this%x(n))
end subroutine t_init
type(t) function x_minus_t(x,this) result(xmt)
real(real64), intent(in) :: x
class(t), intent(in) :: this
call xmt%init(this%n)
xmt%x(:) = x-this%x(:)
end function x_minus_t
subroutine t_print(this,msg)
class(t), intent(in) :: this
character(*), intent(in) :: msg
integer :: i
print "('type(t) object <',a,'>, size=',i0)", msg,this%n
do i=1,this%n
print "(' x(',i0,') =',1pe12.5)",i,this%x(i)
end do
end subroutine t_print
end module myclass
program test_overloaded
use myclass
implicit none
type(t) :: t1,r1
! Error with result (5)
call t1%init(5); t1%x(:) = 1.0_real64; r1 = 3.0_real64 - t1
if (any(r1%x /= 2.0)) stop 1
! call r1%print('r1')
! No errors
call t1%init(6); t1%x(:) = 1.0_real64; r1 = 3.0_real64 - t1
if (any(r1%x /= 2.0)) stop 2
! call r1%print('r1')
return
end program test_overloaded
|
