git.iko.soy/Idris-dev
on 0cb9b4e help sign in
Idris-dev/src/Idris/Primitives.hs
519 lines 23 kB history raw
1{-# LANGUAGE RankNTypes, ScopedTypeVariables, PatternGuards #-}
3module Idris.Primitives(primitives, Prim(..)) where
5import Idris.AbsSyntax
7import IRTS.Lang
9import Idris.Core.TT
10import Idris.Core.Evaluate
11import Data.Bits
12import Data.Word
13import Data.Int
14import Data.Char
15import Data.Function (on)
16import qualified Data.Vector.Unboxed as V
18import Debug.Trace
20data Prim = Prim { p_name :: Name,
21 p_type :: Type,
22 p_arity :: Int,
23 p_def :: [Const] -> Maybe Const,
24 p_lexp :: (Int, PrimFn),
25 p_total :: Totality
26 }
28ty :: [Const] -> Const -> Type
29ty [] x = Constant x
30ty (t:ts) x = Bind (sMN 0 "T") (Pi Nothing (Constant t) (TType (UVar (-3)))) (ty ts x)
32total, partial, iopartial :: Totality
33total = Total []
34partial = Partial NotCovering
35iopartial = Partial ExternalIO
37primitives :: [Prim]
38primitives =
39 -- operators
40 [iCoerce (ITFixed IT8) (ITFixed IT16) "zext" zext LZExt,
41 iCoerce (ITFixed IT8) (ITFixed IT32) "zext" zext LZExt,
42 iCoerce (ITFixed IT8) (ITFixed IT64) "zext" zext LZExt,
43 iCoerce (ITFixed IT8) ITBig "zext" zext LZExt,
44 iCoerce (ITFixed IT8) ITNative "zext" zext LZExt,
45 iCoerce (ITFixed IT16) (ITFixed IT32) "zext" zext LZExt,
46 iCoerce (ITFixed IT16) (ITFixed IT64) "zext" zext LZExt,
47 iCoerce (ITFixed IT16) ITBig "zext" zext LZExt,
48 iCoerce (ITFixed IT16) ITNative "zext" zext LZExt,
49 iCoerce (ITFixed IT32) (ITFixed IT64) "zext" zext LZExt,
50 iCoerce (ITFixed IT32) ITBig "zext" zext LZExt,
51 iCoerce (ITFixed IT32) ITNative "zext" zext LZExt,
52 iCoerce (ITFixed IT64) ITBig "zext" zext LZExt,
53 iCoerce ITNative ITBig "zext" zext LZExt,
54 iCoerce ITNative (ITFixed IT64) "zext" zext LZExt,
55 iCoerce ITNative (ITFixed IT32) "zext" zext LZExt,
56 iCoerce ITNative (ITFixed IT16) "zext" zext LZExt,
57 iCoerce ITChar ITBig "zext" zext LZExt,
59 iCoerce (ITFixed IT8) (ITFixed IT16) "sext" sext LSExt,
60 iCoerce (ITFixed IT8) (ITFixed IT32) "sext" sext LSExt,
61 iCoerce (ITFixed IT8) (ITFixed IT64) "sext" sext LSExt,
62 iCoerce (ITFixed IT8) ITBig "sext" sext LSExt,
63 iCoerce (ITFixed IT8) ITNative "sext" sext LSExt,
64 iCoerce (ITFixed IT16) (ITFixed IT32) "sext" sext LSExt,
65 iCoerce (ITFixed IT16) (ITFixed IT64) "sext" sext LSExt,
66 iCoerce (ITFixed IT16) ITBig "sext" sext LSExt,
67 iCoerce (ITFixed IT16) ITNative "sext" sext LSExt,
68 iCoerce (ITFixed IT32) (ITFixed IT64) "sext" sext LSExt,
69 iCoerce (ITFixed IT32) ITBig "sext" sext LSExt,
70 iCoerce (ITFixed IT32) ITNative "sext" sext LSExt,
71 iCoerce (ITFixed IT64) ITBig "sext" sext LSExt,
72 iCoerce ITNative ITBig "sext" sext LSExt,
73 iCoerce ITNative ITBig "sext" sext LSExt,
74 iCoerce ITNative (ITFixed IT64) "sext" sext LSExt,
75 iCoerce ITNative (ITFixed IT32) "sext" sext LSExt,
76 iCoerce ITNative (ITFixed IT16) "sext" sext LSExt,
77 iCoerce ITChar ITBig "sext" sext LSExt,
79 iCoerce (ITFixed IT16) (ITFixed IT8) "trunc" trunc LTrunc,
80 iCoerce (ITFixed IT32) (ITFixed IT8) "trunc" trunc LTrunc,
81 iCoerce (ITFixed IT64) (ITFixed IT8) "trunc" trunc LTrunc,
82 iCoerce ITBig (ITFixed IT8) "trunc" trunc LTrunc,
83 iCoerce ITNative (ITFixed IT8) "trunc" trunc LTrunc,
84 iCoerce (ITFixed IT32) (ITFixed IT16) "trunc" trunc LTrunc,
85 iCoerce (ITFixed IT64) (ITFixed IT16) "trunc" trunc LTrunc,
86 iCoerce ITBig (ITFixed IT16) "trunc" trunc LTrunc,
87 iCoerce ITNative (ITFixed IT16) "trunc" trunc LTrunc,
88 iCoerce (ITFixed IT64) (ITFixed IT32) "trunc" trunc LTrunc,
89 iCoerce ITBig (ITFixed IT32) "trunc" trunc LTrunc,
90 iCoerce ITNative (ITFixed IT32) "trunc" trunc LTrunc,
91 iCoerce ITBig (ITFixed IT64) "trunc" trunc LTrunc,
92 iCoerce (ITFixed IT16) ITNative "trunc" trunc LTrunc,
93 iCoerce (ITFixed IT32) ITNative "trunc" trunc LTrunc,
94 iCoerce (ITFixed IT64) ITNative "trunc" trunc LTrunc,
95 iCoerce ITBig ITNative "trunc" trunc LTrunc,
96 iCoerce ITNative (ITFixed IT64) "trunc" trunc LTrunc,
97 iCoerce ITBig ITChar "trunc" trunc LTrunc,
99 Prim (sUN "prim__addFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (+))
100 (2, LPlus ATFloat) total,
101 Prim (sUN "prim__subFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (-))
102 (2, LMinus ATFloat) total,
103 Prim (sUN "prim__mulFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (*))
104 (2, LTimes ATFloat) total,
105 Prim (sUN "prim__divFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (/))
106 (2, LSDiv ATFloat) total,
107 Prim (sUN "prim__eqFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (==))
108 (2, LEq ATFloat) total,
109 Prim (sUN "prim__sltFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (<))
110 (2, LSLt ATFloat) total,
111 Prim (sUN "prim__slteFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (<=))
112 (2, LSLe ATFloat) total,
113 Prim (sUN "prim__sgtFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (>))
114 (2, LSGt ATFloat) total,
115 Prim (sUN "prim__sgteFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (>=))
116 (2, LSGe ATFloat) total,
117 Prim (sUN "prim__concat") (ty [StrType, StrType] StrType) 2 (sBin (++))
118 (2, LStrConcat) total,
119 Prim (sUN "prim__eqString") (ty [StrType, StrType] (AType (ATInt ITNative))) 2 (bsBin (==))
120 (2, LStrEq) total,
121 Prim (sUN "prim__ltString") (ty [StrType, StrType] (AType (ATInt ITNative))) 2 (bsBin (<))
122 (2, LStrLt) total,
123 Prim (sUN "prim_lenString") (ty [StrType] (AType (ATInt ITNative))) 1 (p_strLen)
124 (1, LStrLen) total,
125 -- Conversions
126 Prim (sUN "prim__charToInt") (ty [(AType (ATInt ITChar))] (AType (ATInt ITNative))) 1 (c_charToInt)
127 (1, LChInt ITNative) total,
128 Prim (sUN "prim__intToChar") (ty [(AType (ATInt ITNative))] (AType (ATInt ITChar))) 1 (c_intToChar)
129 (1, LIntCh ITNative) partial,
130 Prim (sUN "prim__strToFloat") (ty [StrType] (AType ATFloat)) 1 (c_strToFloat)
131 (1, LStrFloat) total,
132 Prim (sUN "prim__floatToStr") (ty [(AType ATFloat)] StrType) 1 (c_floatToStr)
133 (1, LFloatStr) total,
135 Prim (sUN "prim__floatExp") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatExp)
136 (1, LFExp) total,
137 Prim (sUN "prim__floatLog") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatLog)
138 (1, LFLog) total,
139 Prim (sUN "prim__floatSin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSin)
140 (1, LFSin) total,
141 Prim (sUN "prim__floatCos") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCos)
142 (1, LFCos) total,
143 Prim (sUN "prim__floatTan") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatTan)
144 (1, LFTan) total,
145 Prim (sUN "prim__floatASin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatASin)
146 (1, LFASin) total,
147 Prim (sUN "prim__floatACos") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatACos)
148 (1, LFACos) total,
149 Prim (sUN "prim__floatATan") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatATan)
150 (1, LFATan) total,
151 Prim (sUN "prim__floatSqrt") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSqrt)
152 (1, LFSqrt) total,
153 Prim (sUN "prim__floatFloor") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatFloor)
154 (1, LFFloor) total,
155 Prim (sUN "prim__floatCeil") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCeil)
156 (1, LFCeil) total,
157 Prim (sUN "prim__negFloat") (ty [(AType ATFloat)] (AType ATFloat)) 1 (c_negFloat)
158 (1, LFNegate) total,
160 Prim (sUN "prim__strHead") (ty [StrType] (AType (ATInt ITChar))) 1 (p_strHead)
161 (1, LStrHead) partial,
162 Prim (sUN "prim__strTail") (ty [StrType] StrType) 1 (p_strTail)
163 (1, LStrTail) partial,
164 Prim (sUN "prim__strCons") (ty [(AType (ATInt ITChar)), StrType] StrType) 2 (p_strCons)
165 (2, LStrCons) total,
166 Prim (sUN "prim__strIndex") (ty [StrType, (AType (ATInt ITNative))] (AType (ATInt ITChar))) 2 (p_strIndex)
167 (2, LStrIndex) partial,
168 Prim (sUN "prim__strRev") (ty [StrType] StrType) 1 (p_strRev)
169 (1, LStrRev) total,
170 Prim (sUN "prim__strSubstr") (ty [AType (ATInt ITNative), AType (ATInt ITNative), StrType] StrType) 3 (p_strSubstr)
171 (3, LStrSubstr) total,
173 Prim (sUN "prim__readString") (ty [WorldType] StrType) 1 (p_cantreduce)
174 (1, LReadStr) total, -- total is okay, because we have 'WorldType'
175 Prim (sUN "prim__writeString") (ty [WorldType,StrType] (AType (ATInt ITNative))) 2 (p_cantreduce)
176 (2, LWriteStr) total,
177 Prim (sUN "prim__systemInfo") (ty [AType (ATInt ITNative)] StrType) 1 (p_cantreduce)
178 (1, LSystemInfo) total
179 ] ++ concatMap intOps [ITFixed IT8, ITFixed IT16, ITFixed IT32, ITFixed IT64, ITBig, ITNative, ITChar]
181intOps :: IntTy -> [Prim]
182intOps ity = intCmps ity ++ intArith ity ++ intConv ity
184intSCmps :: IntTy -> [Prim]
185intSCmps ity =
186 [ iCmp ity "slt" False (bCmp ity (sCmpOp ity (<))) (LSLt . ATInt) total
187 , iCmp ity "slte" False (bCmp ity (sCmpOp ity (<=))) (LSLe . ATInt) total
188 , iCmp ity "eq" False (bCmp ity (==)) (LEq . ATInt) total
189 , iCmp ity "sgte" False (bCmp ity (sCmpOp ity (>=))) (LSGe . ATInt) total
190 , iCmp ity "sgt" False (bCmp ity (sCmpOp ity (>))) (LSGt . ATInt) total
191 ]
193intCmps :: IntTy -> [Prim]
194intCmps ITNative = intSCmps ITNative
195intCmps ity =
196 intSCmps ity ++
197 [ iCmp ity "lt" False (bCmp ity (cmpOp ity (<))) LLt total
198 , iCmp ity "lte" False (bCmp ity (cmpOp ity (<=))) LLe total
199 , iCmp ity "gte" False (bCmp ity (cmpOp ity (>=))) LGe total
200 , iCmp ity "gt" False (bCmp ity (cmpOp ity (>))) LGt total
201 ]
203intArith :: IntTy -> [Prim]
204intArith ity =
205 [ iBinOp ity "add" (bitBin ity (+)) (LPlus . ATInt) total
206 , iBinOp ity "sub" (bitBin ity (-)) (LMinus . ATInt) total
207 , iBinOp ity "mul" (bitBin ity (*)) (LTimes . ATInt) total
208 , iBinOp ity "udiv" (bitBin ity div) LUDiv partial
209 , iBinOp ity "sdiv" (bsdiv ity) (LSDiv . ATInt) partial
210 , iBinOp ity "urem" (bitBin ity rem) LURem partial
211 , iBinOp ity "srem" (bsrem ity) (LSRem . ATInt) partial
212 , iBinOp ity "shl" (bitBin ity (\x y -> shiftL x (fromIntegral y))) LSHL total
213 , iBinOp ity "lshr" (bitBin ity (\x y -> shiftR x (fromIntegral y))) LLSHR total
214 , iBinOp ity "ashr" (bashr ity) LASHR total
215 , iBinOp ity "and" (bitBin ity (.&.)) LAnd total
216 , iBinOp ity "or" (bitBin ity (.|.)) LOr total
217 , iBinOp ity "xor" (bitBin ity (xor)) LXOr total
218 , iUnOp ity "compl" (bUn ity complement) LCompl total
219 ]
221intConv :: IntTy -> [Prim]
222intConv ity =
223 [ Prim (sUN $ "prim__toStr" ++ intTyName ity) (ty [AType . ATInt $ ity] StrType) 1 intToStr
224 (1, LIntStr ity) total
225 , Prim (sUN $ "prim__fromStr" ++ intTyName ity) (ty [StrType] (AType . ATInt $ ity)) 1 (strToInt ity)
226 (1, LStrInt ity) total
227 , Prim (sUN $ "prim__toFloat" ++ intTyName ity) (ty [AType . ATInt $ ity] (AType ATFloat)) 1 intToFloat
228 (1, LIntFloat ity) total
229 , Prim (sUN $ "prim__fromFloat" ++ intTyName ity) (ty [AType ATFloat] (AType . ATInt $ ity)) 1 (floatToInt ity)
230 (1, LFloatInt ity) total
231 ]
233bitcastPrim :: ArithTy -> ArithTy -> (ArithTy -> [Const] -> Maybe Const) -> PrimFn -> Prim
234bitcastPrim from to impl prim =
235 Prim (sUN $ "prim__bitcast" ++ aTyName from ++ "_" ++ aTyName to) (ty [AType from] (AType to)) 1 (impl to)
236 (1, prim) total
238concatWord8 :: (Word8, Word8) -> Word16
239concatWord8 (high, low) = fromIntegral high .|. (fromIntegral low `shiftL` 8)
241concatWord16 :: (Word16, Word16) -> Word32
242concatWord16 (high, low) = fromIntegral high .|. (fromIntegral low `shiftL` 16)
244concatWord32 :: (Word32, Word32) -> Word64
245concatWord32 (high, low) = fromIntegral high .|. (fromIntegral low `shiftL` 32)
247truncWord16 :: Bool -> Word16 -> Word8
248truncWord16 True x = fromIntegral (x `shiftR` 8)
249truncWord16 False x = fromIntegral x
251truncWord32 :: Bool -> Word32 -> Word16
252truncWord32 True x = fromIntegral (x `shiftR` 16)
253truncWord32 False x = fromIntegral x
255truncWord64 :: Bool -> Word64 -> Word32
256truncWord64 True x = fromIntegral (x `shiftR` 32)
257truncWord64 False x = fromIntegral x
259aTyName :: ArithTy -> String
260aTyName (ATInt t) = intTyName t
261aTyName ATFloat = "Float"
263iCmp :: IntTy -> String -> Bool -> ([Const] -> Maybe Const) -> (IntTy -> PrimFn) -> Totality -> Prim
264iCmp ity op self impl irop totality
265 = Prim (sUN $ "prim__" ++ op ++ intTyName ity)
266 (ty (replicate 2 . AType . ATInt $ ity) (AType (ATInt (if self then ity else ITNative))))
267 2 impl (2, irop ity) totality
269iBinOp, iUnOp :: IntTy -> String -> ([Const] -> Maybe Const) -> (IntTy -> PrimFn) -> Totality -> Prim
270iBinOp ity op impl irop totality
271 = Prim (sUN $ "prim__" ++ op ++ intTyName ity)
272 (ty (replicate 2 . AType . ATInt $ ity) (AType . ATInt $ ity))
273 2 impl (2, irop ity) totality
274iUnOp ity op impl irop totality
275 = Prim (sUN $ "prim__" ++ op ++ intTyName ity)
276 (ty [AType . ATInt $ ity] (AType . ATInt $ ity))
277 1 impl (1, irop ity) totality
279iCoerce :: IntTy -> IntTy -> String -> (IntTy -> IntTy -> [Const] -> Maybe Const) -> (IntTy -> IntTy -> PrimFn) -> Prim
280iCoerce from to op impl irop =
281 Prim (sUN $ "prim__" ++ op ++ intTyName from ++ "_" ++ intTyName to)
282 (ty [AType . ATInt $ from] (AType . ATInt $ to)) 1 (impl from to) (1, irop from to) total
284fBin :: (Double -> Double -> Double) -> [Const] -> Maybe Const
285fBin op [Fl x, Fl y] = Just $ Fl (op x y)
286fBin _ _ = Nothing
288bfBin :: (Double -> Double -> Bool) -> [Const] -> Maybe Const
289bfBin op [Fl x, Fl y] = let i = (if op x y then 1 else 0) in
290 Just $ I i
291bfBin _ _ = Nothing
293bcBin :: (Char -> Char -> Bool) -> [Const] -> Maybe Const
294bcBin op [Ch x, Ch y] = let i = (if op x y then 1 else 0) in
295 Just $ I i
296bcBin _ _ = Nothing
298bsBin :: (String -> String -> Bool) -> [Const] -> Maybe Const
299bsBin op [Str x, Str y]
300 = let i = (if op x y then 1 else 0) in
301 Just $ I i
302bsBin _ _ = Nothing
304sBin :: (String -> String -> String) -> [Const] -> Maybe Const
305sBin op [Str x, Str y] = Just $ Str (op x y)
306sBin _ _ = Nothing
308bsrem :: IntTy -> [Const] -> Maybe Const
309bsrem ITBig [BI x, BI y] = Just . BI $ x `rem` y
310bsrem (ITFixed IT8) [B8 x, B8 y]
311 = Just $ B8 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int8))
312bsrem (ITFixed IT16) [B16 x, B16 y]
313 = Just $ B16 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int16))
314bsrem (ITFixed IT32) [B32 x, B32 y]
315 = Just $ B32 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int32))
316bsrem (ITFixed IT64) [B64 x, B64 y]
317 = Just $ B64 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int64))
318bsrem ITNative [I x, I y] = Just $ I (x `rem` y)
319bsrem ITChar [Ch x, Ch y] = Just $ Ch (chr $ (ord x) `rem` (ord y))
320bsrem _ _ = Nothing
322bsdiv :: IntTy -> [Const] -> Maybe Const
323bsdiv ITBig [BI x, BI y] = Just . BI $ x `div` y
324bsdiv (ITFixed IT8) [B8 x, B8 y]
325 = Just $ B8 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int8))
326bsdiv (ITFixed IT16) [B16 x, B16 y]
327 = Just $ B16 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int16))
328bsdiv (ITFixed IT32) [B32 x, B32 y]
329 = Just $ B32 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int32))
330bsdiv (ITFixed IT64) [B64 x, B64 y]
331 = Just $ B64 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int64))
332bsdiv ITNative [I x, I y] = Just $ I (x `div` y)
333bsdiv ITChar [Ch x, Ch y] = Just $ Ch (chr $ (ord x) `div` (ord y))
334bsdiv _ _ = Nothing
336bashr :: IntTy -> [Const] -> Maybe Const
337bashr ITBig [BI x, BI y] = Just $ BI (x `shiftR` fromIntegral y)
338bashr (ITFixed IT8) [B8 x, B8 y]
339 = Just $ B8 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int8))
340bashr (ITFixed IT16) [B16 x, B16 y]
341 = Just $ B16 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int16))
342bashr (ITFixed IT32) [B32 x, B32 y]
343 = Just $ B32 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int32))
344bashr (ITFixed IT64) [B64 x, B64 y]
345 = Just $ B64 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int64))
346bashr ITNative [I x, I y] = Just $ I (x `shiftR` y)
347bashr ITChar [Ch x, Ch y] = Just $ Ch (chr $ (ord x) `shiftR` (ord y))
348bashr _ _ = Nothing
350bUn :: IntTy -> (forall a. Bits a => a -> a) -> [Const] -> Maybe Const
351bUn (ITFixed IT8) op [B8 x] = Just $ B8 (op x)
352bUn (ITFixed IT16) op [B16 x] = Just $ B16 (op x)
353bUn (ITFixed IT32) op [B32 x] = Just $ B32 (op x)
354bUn (ITFixed IT64) op [B64 x] = Just $ B64 (op x)
355bUn ITBig op [BI x] = Just $ BI (op x)
356bUn ITNative op [I x] = Just $ I (op x)
357bUn ITChar op [Ch x] = Just $ Ch (chr $ op (ord x))
358bUn _ _ _ = Nothing
360bitBin :: IntTy -> (forall a. (Bits a, Integral a) => a -> a -> a) -> [Const] -> Maybe Const
361bitBin (ITFixed IT8) op [B8 x, B8 y] = Just $ B8 (op x y)
362bitBin (ITFixed IT16) op [B16 x, B16 y] = Just $ B16 (op x y)
363bitBin (ITFixed IT32) op [B32 x, B32 y] = Just $ B32 (op x y)
364bitBin (ITFixed IT64) op [B64 x, B64 y] = Just $ B64 (op x y)
365bitBin ITBig op [BI x, BI y] = Just $ BI (op x y)
366bitBin ITNative op [I x, I y] = Just $ I (op x y)
367bitBin ITChar op [Ch x, Ch y] = Just $ Ch (chr $ op (ord x) (ord y))
368bitBin _ _ _ = Nothing
370bCmp :: IntTy -> (forall a. (Integral a, Ord a) => a -> a -> Bool) -> [Const] -> Maybe Const
371bCmp (ITFixed IT8) op [B8 x, B8 y] = Just $ I (if (op x y) then 1 else 0)
372bCmp (ITFixed IT16) op [B16 x, B16 y] = Just $ I (if (op x y) then 1 else 0)
373bCmp (ITFixed IT32) op [B32 x, B32 y] = Just $ I (if (op x y) then 1 else 0)
374bCmp (ITFixed IT64) op [B64 x, B64 y] = Just $ I (if (op x y) then 1 else 0)
375bCmp ITBig op [BI x, BI y] = Just $ I (if (op x y) then 1 else 0)
376bCmp ITNative op [I x, I y] = Just $ I (if (op x y) then 1 else 0)
377bCmp ITChar op [Ch x, Ch y] = Just $ I (if (op (ord x) (ord y)) then 1 else 0)
378bCmp _ _ _ = Nothing
381cmpOp :: (Ord a, Integral a) => IntTy -> (forall b. Ord b => b -> b -> Bool) -> a -> a -> Bool
382cmpOp (ITFixed _) f = f
383cmpOp (ITNative) f = f `on` (fromIntegral :: Integral a => a -> Word)
384cmpOp (ITChar) f = f `on` ((fromIntegral :: Integral a => a -> Word))
385cmpOp _ f = let xor = (/=) in (\ x y -> (f x y) `xor` (x < 0) `xor` (y < 0))
387sCmpOp :: (Ord a, Integral a) => IntTy -> (forall b. Ord b => b -> b -> Bool) -> a -> a -> Bool
388sCmpOp (ITFixed IT8) f = f `on` (fromIntegral :: Integral a => a -> Int8)
389sCmpOp (ITFixed IT16) f = f `on` (fromIntegral :: Integral a => a -> Int16)
390sCmpOp (ITFixed IT32) f = f `on` (fromIntegral :: Integral a => a -> Int32)
391sCmpOp (ITFixed IT64) f = f `on` (fromIntegral :: Integral a => a -> Int64)
392sCmpOp _ f = f
394toInt :: Integral a => IntTy -> a -> Const
395toInt (ITFixed IT8) x = B8 (fromIntegral x)
396toInt (ITFixed IT16) x = B16 (fromIntegral x)
397toInt (ITFixed IT32) x = B32 (fromIntegral x)
398toInt (ITFixed IT64) x = B64 (fromIntegral x)
399toInt ITBig x = BI (fromIntegral x)
400toInt ITNative x = I (fromIntegral x)
401toInt ITChar x = Ch (chr $ fromIntegral x)
403intToInt :: IntTy -> IntTy -> [Const] -> Maybe Const
404intToInt (ITFixed IT8) out [B8 x] = Just $ toInt out x
405intToInt (ITFixed IT16) out [B16 x] = Just $ toInt out x
406intToInt (ITFixed IT32) out [B32 x] = Just $ toInt out x
407intToInt (ITFixed IT64) out [B64 x] = Just $ toInt out x
408intToInt ITBig out [BI x] = Just $ toInt out x
409intToInt ITNative out [I x] = Just $ toInt out x
410intToInt ITChar out [Ch x] = Just $ toInt out (ord x)
411intToInt _ _ _ = Nothing
413zext :: IntTy -> IntTy -> [Const] -> Maybe Const
414zext from ITBig val = intToInt from ITBig val
415zext ITBig _ _ = Nothing
416zext f@(ITFixed from) t@(ITFixed to) val
417 | nativeTyWidth from < nativeTyWidth to = intToInt f t val
418zext ITNative to [I x] = Just $ toInt to (fromIntegral x :: Word)
419zext from ITNative val = intToInt from ITNative val
420zext _ _ _ = Nothing
422sext :: IntTy -> IntTy -> [Const] -> Maybe Const
423sext (ITFixed IT8) out [B8 x] = Just $ toInt out (fromIntegral x :: Int8)
424sext (ITFixed IT16) out [B16 x] = Just $ toInt out (fromIntegral x :: Int16)
425sext (ITFixed IT32) out [B32 x] = Just $ toInt out (fromIntegral x :: Int32)
426sext (ITFixed IT64) out [B64 x] = Just $ toInt out (fromIntegral x :: Int64)
427sext ITBig _ _ = Nothing
428sext from to val = intToInt from to val
430trunc :: IntTy -> IntTy -> [Const] -> Maybe Const
431trunc ITBig to val = intToInt ITBig to val
432trunc _ ITBig _ = Nothing
433trunc f@(ITFixed from) t@(ITFixed to) val | nativeTyWidth from > nativeTyWidth to = intToInt f t val
434trunc ITNative to [I x] = Just $ toInt to x
435trunc from ITNative val = intToInt from ITNative val
436trunc _ _ _ = Nothing
438intToStr :: [Const] -> Maybe Const
439intToStr val | [i] <- getInt val = Just $ Str (show i)
440intToStr _ = Nothing
442getInt :: [Const] -> [Integer]
443getInt (B8 x : xs) = toInteger x : getInt xs
444getInt (B16 x : xs) = toInteger x : getInt xs
445getInt (B32 x : xs) = toInteger x : getInt xs
446getInt (B64 x : xs) = toInteger x : getInt xs
447getInt (I x : xs) = toInteger x : getInt xs
448getInt (BI x : xs) = x : getInt xs
449getInt _ = []
451strToInt :: IntTy -> [Const] -> Maybe Const
452strToInt ity [Str x] = case reads x of
453 [(n,"")] -> Just $ toInt ity (n :: Integer)
454 _ -> Just $ I 0
455strToInt _ _ = Nothing
457intToFloat :: [Const] -> Maybe Const
458intToFloat val | [i] <- getInt val = Just $ Fl (fromIntegral i)
459intToFloat _ = Nothing
461floatToInt :: IntTy -> [Const] -> Maybe Const
462floatToInt ity [Fl x] = Just $ toInt ity (truncate x :: Integer)
463floatToInt _ _ = Nothing
465c_intToChar, c_charToInt :: [Const] -> Maybe Const
466c_intToChar [(I x)] = Just . Ch . toEnum $ x
467c_intToChar _ = Nothing
468c_charToInt [(Ch x)] = Just . I . fromEnum $ x
469c_charToInt _ = Nothing
471c_negFloat :: [Const] -> Maybe Const
472c_negFloat [Fl x] = Just $ Fl (negate x)
473c_negFloat _ = Nothing
475c_floatToStr :: [Const] -> Maybe Const
476c_floatToStr [Fl x] = Just $ Str (show x)
477c_floatToStr _ = Nothing
478c_strToFloat [Str x] = case reads x of
479 [(n,"")] -> Just $ Fl n
480 _ -> Just $ Fl 0
481c_strToFloat _ = Nothing
483p_fPrim :: (Double -> Double) -> [Const] -> Maybe Const
484p_fPrim f [Fl x] = Just $ Fl (f x)
485p_fPrim f _ = Nothing
487p_floatExp, p_floatLog, p_floatSin, p_floatCos, p_floatTan, p_floatASin, p_floatACos, p_floatATan, p_floatSqrt, p_floatFloor, p_floatCeil :: [Const] -> Maybe Const
488p_floatExp = p_fPrim exp
489p_floatLog = p_fPrim log
490p_floatSin = p_fPrim sin
491p_floatCos = p_fPrim cos
492p_floatTan = p_fPrim tan
493p_floatASin = p_fPrim asin
494p_floatACos = p_fPrim acos
495p_floatATan = p_fPrim atan
496p_floatSqrt = p_fPrim sqrt
497p_floatFloor = p_fPrim (fromInteger . floor)
498p_floatCeil = p_fPrim (fromInteger . ceiling)
500p_strLen, p_strHead, p_strTail, p_strIndex, p_strCons, p_strRev, p_strSubstr :: [Const] -> Maybe Const
501p_strLen [Str xs] = Just $ I (length xs)
502p_strLen _ = Nothing
503p_strHead [Str (x:xs)] = Just $ Ch x
504p_strHead _ = Nothing
505p_strTail [Str (x:xs)] = Just $ Str xs
506p_strTail _ = Nothing
507p_strIndex [Str xs, I i]
508 | i < length xs = Just $ Ch (xs!!i)
509p_strIndex _ = Nothing
510p_strCons [Ch x, Str xs] = Just $ Str (x:xs)
511p_strCons _ = Nothing
512p_strRev [Str xs] = Just $ Str (reverse xs)
513p_strRev _ = Nothing
514p_strSubstr [I offset, I length, Str input] = Just $ Str (take length (drop offset input))
515p_strSubstr _ = Nothing
518p_cantreduce :: a -> Maybe b
519p_cantreduce _ = Nothing