ghc/tests/codeGen/should_run/cg042.hs

   1 -- !!! mutable Double array test (ncg test)
   2 --
   3 module Main ( main ) where
   4
   5 import PrelBase --ghc1.3
   6 import IOExts
   7 import ByteArray
   8 import MutableArray
   9 import ST
  10
  11 import Ratio   -- 1.3
  12 import Array   -- 1.3
  13
  14 main = --primIOToIO (newDoubleArray (0,1) >>= \ arr -> readDoubleArray arr 0) >>= print
  15  putStr test_doubles
  16
  17
  18 test_doubles :: String
  19 test_doubles
  20   = let arr# = f 1000
  21     in
  22         shows (lookup_range arr# 42# 416#) "\n"
  23   where
  24     f :: Int -> ByteArray Int
  25
  26     f size@(I# size#)
  27       = runST (
  28             -- allocate an array of the specified size
  29           newDoubleArray (0, (size-1))  >>= \ arr# ->
  30
  31             -- fill in all elements; elem i has "i * pi" put in it
  32           fill_in arr# 0# (size# -# 1#) >>
  33
  34             -- freeze the puppy:
  35           freezeDoubleArray arr#
  36         )
  37
  38     fill_in :: MutableByteArray s Int -> Int# -> Int# -> ST s ()
  39
  40     fill_in arr_in# first# last#
  41       = if (first# ># last#)
  42         then return ()
  43         else writeDoubleArray arr_in# (I# first#) ((fromInt (I# first#)) * pi) >>
  44              fill_in arr_in# (first# +# 1#) last#
  45
  46     lookup_range :: ByteArray Int -> Int# -> Int# -> [Double]
  47     lookup_range arr from# to#
  48       = if (from# ># to#)
  49         then []
  50         else (indexDoubleArray arr (I# from#))
  51              : (lookup_range arr (from# +# 1#) to#)