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