@@ -22,6 +22,7 @@ import Control.Monad.Trans.State.Strict
2222import Control.Monad.Trans.Error
2323import Control.Monad
2424import Data.Maybe
25+import Data.Bits
2526import qualified Data.Map as M
2627
2728import Foreign.LibFFI
@@ -169,6 +170,7 @@ ioUnit = ioWrap (EP Ref unitCon EErased)
169170type ExecEnv = [(Name, ExecVal)]
170171
171172doExec :: ExecEnv -> Context -> Term -> Exec ExecVal
173+doExec env ctxt p@(P Ref n ty) | Just v <- lookup n env = return v
172174doExec env ctxt p@(P Ref n ty) =
173175 do let val = lookupDef n ctxt
174176 case val of
@@ -178,6 +180,7 @@ doExec env ctxt p@(P Ref n ty) =
178180 [CaseOp _ _ _ _ _ [] (STerm tm) _ _] -> -- nullary fun
179181 doExec env ctxt tm
180182 [CaseOp _ _ _ _ _ ns sc _ _] -> return (EP Ref n EErased)
183+ [] -> execFail $ "Could not find " ++ show n ++ " in definitions."
181184 thing -> trace (take 200 $ "got to " ++ show thing ++ " lookup up " ++ show n) $ undefined
182185doExec env ctxt p@(P Bound n ty) =
183186 case lookup n env of
@@ -257,12 +260,17 @@ execApp' env ctxt (EP _ (UN "mkForeign") _) (_:fn:(EHandle h):rest)
257260 | Just (FFun "fileClose" _ _) <- foreignFromTT fn = do execIO $ hClose h
258261 execApp' env ctxt ioUnit rest
259262
263+execApp' env ctxt (EP _ (UN "mkForeign") _) (_:fn:(EPtr p):rest)
264+ | Just (FFun "isNull" _ _) <- foreignFromTT fn = let res = ioWrap . EConstant . I $
265+ if p == nullPtr then 1 else 0
266+ in execApp' env ctxt res rest
260267
261−execApp' env ctxt f@(EP _ (UN "mkForeign") _) args@(ty:fn:xs) | Just (FFun _ argTs retT) <- foreignFromTT fn
268+execApp' env ctxt f@(EP _ (UN "mkForeign") _) args@(ty:fn:xs) | Just (FFun f argTs retT) <- foreignFromTT fn
262269 , length xs >= length argTs =
263270 do res <- stepForeign (ty:fn:take (length argTs) xs)
264271 case res of
265− Nothing -> fail "Could not call foreign function"
272+ Nothing -> fail $ "Could not call foreign function \"" ++ f ++
273+ "\" with args " ++ show (take (length argTs) xs)
266274 Just r -> return (mkEApp r (drop (length argTs) xs))
267275 | otherwise = return (mkEApp f args)
268276
@@ -289,34 +297,64 @@ execApp' env ctxt f@(EP _ n _) args =
289297 where getOp :: Name -> [ExecVal] -> Maybe (Exec ExecVal)
290298 getOp (UN "prim__addInt") [EConstant (I i1), EConstant (I i2)] =
291299 primRes I (i1 + i2)
300+ getOp (UN "prim__andInt") [EConstant (I i1), EConstant (I i2)] =
301+ primRes I (i1 .&. i2)
292302 getOp (UN "prim__charToInt") [EConstant (Ch c)] =
293303 primRes I (fromEnum c)
304+ getOp (UN "prim__complInt") [EConstant (I i)] =
305+ primRes I (complement i)
294306 getOp (UN "prim__concat") [EConstant (Str s1), EConstant (Str s2)] =
295307 primRes Str (s1 ++ s2)
308+ getOp (UN "prim__divInt") [EConstant (I i1), EConstant (I i2)] =
309+ primRes I (i1 `div` i2)
296310 getOp (UN "prim__eqChar") [EConstant (Ch c1), EConstant (Ch c2)] =
297311 primResBool (c1 == c2)
298312 getOp (UN "prim__eqInt") [EConstant (I i1), EConstant (I i2)] =
299313 primResBool (i1 == i2)
300314 getOp (UN "prim__eqString") [EConstant (Str s1), EConstant (Str s2)] =
301315 primResBool (s1 == s2)
316+ getOp (UN "prim__gtChar") [EConstant (Ch i1), EConstant (Ch i2)] =
317+ primResBool (i1 > i2)
318+ getOp (UN "prim__gteChar") [EConstant (Ch i1), EConstant (Ch i2)] =
319+ primResBool (i1 >= i2)
320+ getOp (UN "prim__gtInt") [EConstant (I i1), EConstant (I i2)] =
321+ primResBool (i1 > i2)
322+ getOp (UN "prim__gteInt") [EConstant (I i1), EConstant (I i2)] =
323+ primResBool (i1 >= i2)
302324 getOp (UN "prim__intToFloat") [EConstant (I i)] =
303325 primRes Fl (fromRational (toRational i))
304326 getOp (UN "prim__intToStr") [EConstant (I i)] =
305327 primRes Str (show i)
328+ getOp (UN "prim_lenString") [EConstant (Str s)] =
329+ primRes I (length s)
330+ getOp (UN "prim__ltChar") [EConstant (Ch i1), EConstant (Ch i2)] =
331+ primResBool (i1 < i2)
332+ getOp (UN "prim__lteChar") [EConstant (Ch i1), EConstant (Ch i2)] =
333+ primResBool (i1 <= i2)
334+ getOp (UN "prim__lteInt") [EConstant (I i1), EConstant (I i2)] =
335+ primResBool (i1 <= i2)
306336 getOp (UN "prim__ltInt") [EConstant (I i1), EConstant (I i2)] =
307337 primResBool (i1 < i2)
338+ getOp (UN "prim__modInt") [EConstant (I i1), EConstant (I i2)] =
339+ primRes I (i1 `mod` i2)
308340 getOp (UN "prim__mulBigInt") [EConstant (BI i1), EConstant (BI i2)] =
309341 primRes BI (i1 * i2)
310342 getOp (UN "prim__mulFloat") [EConstant (Fl i1), EConstant (Fl i2)] =
311343 primRes Fl (i1 * i2)
312344 getOp (UN "prim__mulInt") [EConstant (I i1), EConstant (I i2)] =
313345 primRes I (i1 * i2)
346+ getOp (UN "prim__orInt") [EConstant (I i1), EConstant (I i2)] =
347+ primRes I (i1 .|. i2)
314348 getOp (UN "prim__readString") [EP _ (UN "prim__stdin") _] =
315349 Just $ do line <- execIO getLine
316350 return (EConstant (Str line))
317351 getOp (UN "prim__readString") [EHandle h] =
318352 Just $ do contents <- execIO $ hGetLine h
319353 return (EConstant (Str contents))
354+ getOp (UN "prim__shLInt") [EConstant (I i1), EConstant (I i2)] =
355+ primRes I (shiftL i1 i2)
356+ getOp (UN "prim__shRInt") [EConstant (I i1), EConstant (I i2)] =
357+ primRes I (shiftR i1 i2)
320358 getOp (UN "prim__strCons") [EConstant (Ch c), EConstant (Str s)] =
321359 primRes Str (c:s)
322360 getOp (UN "prim__strHead") [EConstant (Str (c:s))] =
@@ -329,6 +367,8 @@ execApp' env ctxt f@(EP _ n _) args =
329367 primRes Fl (i1 - i2)
330368 getOp (UN "prim__subInt") [EConstant (I i1), EConstant (I i2)] =
331369 primRes I (i1 - i2)
370+ getOp (UN "prim__xorInt") [EConstant (I i1), EConstant (I i2)] =
371+ primRes I (i1 `xor` i2)
332372 getOp n args = trace ("No prim " ++ show n ++ " for " ++ take 1000 (show args)) Nothing
333373
334374 primRes :: (a -> Const) -> a -> Maybe (Exec ExecVal)
@@ -356,6 +396,7 @@ execCase env ctxt ns sc args =
356396 let arity = length ns in
357397 if arity <= length args
358398 then do let amap = zip ns args
399+-- trace ("Case " ++ show sc ++ "\n in " ++ show amap ++"\n in env " ++ show env ++ "\n\n" ) $ return ()
359400 caseRes <- execCase' env ctxt amap sc
360401 case caseRes of
361402 Just res -> Just <$> execApp' (map (\(n, tm) -> (n, tm)) amap ++ env) ctxt res (drop arity args)