Имеется следующий дополнительный модуль Haskell:
module AllocSymbols (
(↑≣), -- mallocArray
(≣⊠), -- free
(≣→), -- peekElemOff
(≣←), -- pokeElemOff
(⥱), -- peekElemOff unsafe
(⥅), -- advancePtr
) where
import GHC.Ptr
import System.IO.Unsafe
import Foreign.Storable
import Foreign.Marshal.Alloc (free)
import Foreign.Marshal.Array
(↑≣) :: Storable a ⇒ Int → IO (Ptr a)
(↑≣) = mallocArray
(⥱) :: Storable a ⇒ Ptr a → Int → a
a ⥱ i = unsafePerformIO $ peekElemOff a i
(≣→) :: Storable a ⇒ Ptr a → Int → IO a
(≣→) = peekElemOff
(≣←) :: Storable a ⇒ Ptr a → Int → a → IO ()
(≣←) = pokeElemOff
(⥅) :: Storable a ⇒ Ptr a → Int → Ptr a
(⥅) = advancePtr
(≣⊠) :: Ptr a → IO ()
(≣⊠) = Foreign.Marshal.Alloc.free
И теперь мы можем портировать этот фрагмент кода на Фортране:
PROGRAM Test
IMPLICIT NONE
REAL t, ta(2), etime
INTEGER i
DOUBLE PRECISION x
do i = 1, 10000
x = sin( cos( i * 1.0 d0 ) )
print *, x
enddo
ta(1) = 0.0d0
ta(2) = 0.0d0
t = etime( ta )
PRINT *, 'user time: ', ta(1)
PRINT *, 'system time: ', ta(2)
PRINT *, 'process time: ', t
END
слово в слово в Haskell:
module Main where
import GHC.Ptr
import AllocSymbols
import Control.Monad
foreign import ccall etime_ :: Ptr Float → IO Float
main :: IO ()
main = do
mapM_ (print . sin . cos . (* (1.0 :: Double)) . fromIntegral) [1 .. 10000 :: Int]
ta ← (2 ↑≣) -- ta :: Ptr Float
(ta ≣← 0) 0.0
(ta ≣← 1) 0.0
t ← etime_ ta
putStrLn $ " user time: " ++ show (ta ⥱ 0)
putStrLn $ " system time: " ++ show (ta ⥱ 1)
putStrLn $ " process time: " ++ show t
(ta ≣⊠) -- optional in this case