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