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