--- /dev/null
+-- mimic "hbc_library" module, Word.
+-- [seriously non-std Haskell here]
+--
+module Word (
+ Bits(..), -- class
+ Byte, Short, Word, -- data types: abstract
+ byteToInt, shortToInt, wordToInt,
+ wordToShorts, wordToBytes, bytesToString
+ ) where
+
+infixl 8 `bitLsh`, `bitRsh`
+infixl 7 `bitAnd`
+infixl 6 `bitXor`
+infixl 5 `bitOr`
+
+class Bits a where
+ bitAnd, bitOr, bitXor :: a -> a -> a
+ bitCompl :: a -> a
+ bitRsh, bitLsh :: a -> Int -> a
+ bitSwap :: a -> a
+ bit0 :: a
+ bitSize :: a -> Int
+
+------------------------------------------------------------------
+data Word = Word Word# deriving (Eq, Ord)
+
+instance Bits Word where
+ bitAnd (Word x) (Word y) = case and# x y of z -> Word z
+ bitOr (Word x) (Word y) = case or# x y of z -> Word z
+ bitXor (Word x) (Word y) = error "later..." -- Word (XOR x y)
+ bitCompl (Word x) = case not# x of x' -> Word x'
+ bitLsh (Word x) (I# y) = case shiftL# x y of z -> Word z
+ bitRsh (Word x) (I# y) = case shiftRL# x y of z -> Word z
+ bitSwap (Word x) = --Word (OR (LSH x 16) (AND (RSH x 16) 65535))
+ case shiftL# x 16# of { a# ->
+ case shiftRL# x 16# of { b# ->
+ case and# b# (i2w 65535#) of { c# ->
+ case or# a# c# of { r# ->
+ Word r# }}}}
+ bit0 = Word (i2w 1#)
+ bitSize (Word _) = 32
+
+w2i x = word2Int# x
+i2w x = int2Word# x
+
+instance Num Word where
+ Word x + Word y = case plusInt# (w2i x) (w2i y) of z -> Word (i2w z)
+ Word x - Word y = case minusInt# (w2i x) (w2i y) of z -> Word (i2w z)
+ Word x * Word y = case timesInt# (w2i x) (w2i y) of z -> Word (i2w z)
+ negate (Word x) = case negateInt# (w2i x) of z -> Word (i2w z)
+ fromInteger (J# a# s# d#)
+ = case integer2Int# a# s# d# of { z# ->
+ Word (i2w z#) }
+ fromInt (I# x) = Word (i2w x)
+
+instance Text Word where
+ showsPrec _ (Word w) =
+ let i = toInteger (I# (w2i w)) + (if geWord# w (i2w 0#) then 0 else 2*(toInteger maxInt + 1))
+ in showString (conv 8 i)
+
+conv :: Int -> Integer -> String
+conv 0 _ = ""
+conv n i = conv (n-1) q ++ ["0123456789ABCDEF"!!r] where (q, r) = quotRem i 16
+
+------------------------------------------------------------------
+data Short = Short Word# deriving (Eq, Ord)
+
+sHORTMASK x = and# x (i2w 65535#)
+
+instance Bits Short where
+ bitAnd (Short x) (Short y) = case and# x y of z -> Short z
+ bitOr (Short x) (Short y) = case or# x y of z -> Short z
+ bitXor (Short x) (Short y) = error "later..." -- Short (XOR x y)
+ bitCompl (Short x) = case not# x of x' -> Short (sHORTMASK x')
+ bitLsh (Short x) (I# y) = case shiftL# x y of z -> Short (sHORTMASK z)
+ bitRsh (Short x) (I# y) = case shiftRL# x y of z -> Short z
+ bitSwap (Short x) = --Short (SHORTMASK(OR (LSH x 8) (AND (RSH x 8) 255)))
+ case shiftL# x 8# of { a# ->
+ case shiftRL# x 8# of { b# ->
+ case and# b# (i2w 255#) of { c# ->
+ case or# a# c# of { r# ->
+ Short (sHORTMASK r#) }}}}
+ bit0 = Short (i2w 1#)
+ bitSize (Short _) = 16
+
+instance Num Short where
+ Short x + Short y = case plusInt# (w2i x) (w2i y) of z -> Short (sHORTMASK (i2w z))
+ Short x - Short y = case minusInt# (w2i x) (w2i y) of z -> Short (sHORTMASK (i2w z))
+ Short x * Short y = case timesInt# (w2i x) (w2i y) of z -> Short (sHORTMASK (i2w z))
+ negate (Short x) = case negateInt# (w2i x) of z -> Short (sHORTMASK (i2w z))
+ fromInteger (J# a# s# d#)
+ = case integer2Int# a# s# d# of { z# ->
+ Short (sHORTMASK (i2w z#)) }
+ fromInt (I# x) = Short (sHORTMASK (i2w x))
+
+instance Text Short where
+ showsPrec _ (Short w) =
+ let i = toInteger (I# (w2i w))
+ in showString (conv 4 i)
+-- showsType _ = showString "Short"
+
+------------------------------------------------------------------
+data Byte = Byte Word# deriving (Eq, Ord)
+
+bYTEMASK x = and# x (i2w 255#)
+
+instance Bits Byte where
+ bitAnd (Byte x) (Byte y) = case and# x y of z -> Byte z
+ bitOr (Byte x) (Byte y) = case or# x y of z -> Byte z
+ bitXor (Byte x) (Byte y) = error "later..." -- Byte (XOR x y)
+ bitCompl (Byte x) = case not# x of x' -> Byte (bYTEMASK x')
+ bitLsh (Byte x) (I# y) = case shiftL# x y of z -> Byte (bYTEMASK z)
+ bitRsh (Byte x) (I# y) = case shiftRL# x y of z -> Byte z
+ bitSwap (Byte x) = --Byte (BYTEMASK(OR (LSH x 4) (AND (RSH x 8) 15)))
+ case shiftL# x 4# of { a# ->
+ case shiftRL# x 8# of { b# ->
+ case and# b# (i2w 15#) of { c# ->
+ case or# a# c# of { r# ->
+ Byte (bYTEMASK r#) }}}}
+ bit0 = Byte (i2w 1#)
+ bitSize (Byte _) = 8
+
+instance Num Byte where
+ Byte x + Byte y = case plusInt# (w2i x) (w2i y) of z -> Byte (bYTEMASK (i2w z))
+ Byte x - Byte y = case minusInt# (w2i x) (w2i y) of z -> Byte (bYTEMASK (i2w z))
+ Byte x * Byte y = case timesInt# (w2i x) (w2i y) of z -> Byte (bYTEMASK (i2w z))
+ negate (Byte x) = case negateInt# (w2i x) of z -> Byte (bYTEMASK (i2w z))
+ fromInteger (J# a# s# d#)
+ = case integer2Int# a# s# d# of { z# ->
+ Byte (bYTEMASK (i2w z#)) }
+ fromInt (I# x) = Byte (bYTEMASK (i2w x))
+
+instance Text Byte where
+ showsPrec _ (Byte w) =
+ let i = toInteger (I# (w2i w))
+ in showString (conv 2 i)
+-- showsType _ = showString "Byte"
+
+------------------------------------------------------------------
+wordToShorts (Word w) = [Short (sHORTMASK(shiftRL# w 16#)), Short (sHORTMASK(w))]
+wordToBytes (Word w) = [Byte (bYTEMASK(shiftRL# w 24#)), Byte (bYTEMASK(shiftRL# w 16#)), Byte (bYTEMASK(shiftRL# w 8#)), Byte (bYTEMASK(w))]
+
+bytesToString :: [Byte] -> String
+bytesToString bs = map (\ (Byte b) -> chr (I# (w2i b))) bs
+
+stringToBytes :: String -> [Byte]
+stringToBytes cs = map (\c -> Byte (case ord c of {I# i -> bYTEMASK (i2w i)})) cs
+
+wordToInt :: Word -> Int
+wordToInt (Word w) = I# (w2i w)
+
+shortToInt :: Short -> Int
+shortToInt (Short w) = I# (w2i w)
+
+byteToInt :: Byte -> Int
+byteToInt (Byte w) = I# (w2i w)
projects / ghc-hetmet.git / blobdiff