Clicky
Showing changes from revision #0 to #1:
(追記) Added (追記ここまで) | (削除) Removed (削除ここまで) | (削除) Chan (削除ここまで)(追記) ged (追記ここまで)
! An example of an unlimited polymorphic entity used to construct a generic swap function.
! It would be nice if TRANSFER or "=" worked with unlimited polymorphic entities; and
module m
use, intrinsic :: iso_fortran_env, only : int8,int16,int32,int64,real32,real64,real128
implicit none
private
public :: swap
integer,parameter :: dble=kind(0.0d0)
interface swap
module procedure swap_scalar
end interface
contains
!===============================================================================
function anything_to_bytes(anything) result(chars)
implicit none
class(*),intent(in) :: anything
character(len=1),allocatable :: chars(:)
select type(anything)
type is (character(len=*)); chars=transfer(anything,chars)
type is (complex); chars=transfer(anything,chars)
type is (complex(kind=dble)); chars=transfer(anything,chars)
type is (integer(kind=int8)); chars=transfer(anything,chars)
type is (integer(kind=int16)); chars=transfer(anything,chars)
type is (integer(kind=int32)); chars=transfer(anything,chars)
type is (integer(kind=int64)); chars=transfer(anything,chars)
type is (real(kind=real32)); chars=transfer(anything,chars)
type is (real(kind=real64)); chars=transfer(anything,chars)
type is (real(kind=real128)); chars=transfer(anything,chars)
class default
stop 'crud. anything_to_bytes(1) does not know about this type'
end select
end function anything_to_bytes
!===============================================================================
subroutine bytes_to_anything(chars,anything)
character(len=1),allocatable :: chars(:)
class(*) :: anything
select type(anything)
type is (character(len=*)); anything=transfer(chars,anything)
type is (complex); anything=transfer(chars,anything)
type is (complex(kind=dble)); anything=transfer(chars,anything)
type is (integer(kind=int8)); anything=transfer(chars,anything)
type is (integer(kind=int16)); anything=transfer(chars,anything)
type is (integer(kind=int32)); anything=transfer(chars,anything)
type is (integer(kind=int64)); anything=transfer(chars,anything)
type is (real(kind=real32)); anything=transfer(chars,anything)
type is (real(kind=real64)); anything=transfer(chars,anything)
type is (real(kind=real128)); anything=transfer(chars,anything)
class default
stop 'crud. bytes_to_anything(1) does not know about this type'
end select
end subroutine bytes_to_anything
!===============================================================================
subroutine swap_scalar( lhs, rhs )
class(*) :: rhs
class(*) :: lhs
character(len=1),allocatable :: templ(:)
character(len=1),allocatable :: tempr(:)
tempr=anything_to_bytes(rhs)
templ=anything_to_bytes(lhs)
call bytes_to_anything(templ,rhs)
call bytes_to_anything(tempr,lhs)
end subroutine swap_scalar
!===============================================================================
end module
!===============================================================================
program p
use m, only : swap
blk1: block
integer, parameter :: IP = selected_int_kind( r=2 )
integer(IP) :: a, b
print *, "Block 1"
a = 2_ip
b = 3_ip
call swap( a, b )
print *, "a = ", a, a==3
print *, "b = ", b, b==2
end block blk1
blk2: block
integer, parameter :: IP = selected_int_kind( r=10 )
integer(IP) :: a, b
print *, "Block 2"
a = (2_ip)**42
b = (2_ip)**43
call swap( a, b )
print *, "a = ", a, a==(2_ip)**43
print *, "b = ", b, b==(2_ip)**42
end block blk2
blk4: block
real :: a, b
print *, "Block 4"
a = -99.0
b = 99.0
call swap( a, b )
print *, "a = ", a, a==99.0
print *, "b = ", b, b==-99.0
end block blk4
blk5: block
character(len=:), allocatable :: a, b
print *, "Block 5"
a = "foo"
b = "bar"
call swap( a, b )
print *, "a = ", a, a=="bar"
print *, "b = ", b, b=="foo"
end block blk5
stop
end program p