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