mirror of
https://github.com/autc04/Retro68.git
synced 2024-06-28 11:30:19 +00:00
85 lines
1.8 KiB
Fortran
85 lines
1.8 KiB
Fortran
! { 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
|