1 module WriteRoutines (outputCodes)
    2 where
    3 
    4 --import GlaExts
    5 import GHC.Base ( Int(..), word2Int#, int2Word#, and#, or#, shiftL#, shiftRL# )
    6 import Encode (CodeEvent(..))
    7 
    8 -- Start of code added for ghc
    9 w2i x = word2Int# x
   10 i2w x = int2Word# x
   11 
   12 intAnd (I# x) (I# y) = I# (w2i (and# (i2w x) (i2w y)))
   13 intOr  (I# x) (I# y) = I# (w2i (or# (i2w x) (i2w y)))
   14 intLsh (I# x) (I# y) = I# (w2i (shiftL# (i2w x) y))
   15 intRsh (I# x) (I# y) = I# (w2i (shiftRL# (i2w x) y))
   16 -- End of code added for ghc
   17 
   18 outputCodes :: [CodeEvent] -> (String, [Int])
   19 outputCodes cs = (map (\x -> toEnum (intAnd 255 x)) (fst result), snd result)
   20                where result = output 9 8 0 0 cs       -- assume 9 bit start
   21 
   22 output :: Int -> Int -> Int -> Int -> [CodeEvent] -> ([Int], [Int])
   23 output _ _ _ prev [] = ([prev], [1])
   24 
   25 output nbits stillToGo r_off prev (NewWordSize : cs)
   26     = (fst rest, 0 : snd rest)
   27       where
   28       rest = output (nbits + 1) 8 0 0 cs
   29       outBits = if stillToGo /= 8 then nbits else 0
   30 
   31 output nbits stillToGo r_off prev (Clear : cs)
   32     = ((prev : 1 : take' padBits padding) ++ fst rest, outBits : snd rest)
   33       where
   34       rest = output 9 8 0 0 cs
   35       outBits = if stillToGo /= 8 then nbits else 0
   36       padBits = nbits - ((9 - stillToGo) * 2)
   37       take' n l = if n < 0 then take 1 l else take n l
   38 
   39 output nbits stillToGo r_off prev css@(Code code : cs)
   40 
   41     | stillToGo == 0 = output nbits 8 0 0 css
   42     | otherwise = if (nbits + r_off) >= 16 then
   43                       (byte1 : byte2 : fst rest1, outBits : snd rest1)
   44                   else
   45                       (byte1 : fst rest2, outBits : snd rest2)
   46       where
   47       r_off' = 8 - r_off
   48       byte1 = intOr prev (intLsh code r_off)
   49       byte2 = intRsh code r_off'
   50       byte3 = intRsh byte2 8
   51       outBits = if stillToGo == 1 then nbits else 0
   52       rest1 = output nbits (stillToGo-1) ((r_off+nbits) `mod` 8) byte3 cs
   53       rest2 = output nbits (stillToGo-1) ((r_off+nbits) `mod` 8) byte2 cs
   54 
   55 padding :: [Int]
   56 padding = [255, 255 ..]