uplime/lamb
uplime
/
lamb
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

implement kill\!

This commit is contained in:
darkf 2015-02-13 04:08:58 -08:00
parent 1ded14b348
commit 715efff347
1 changed files with 8 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
Interp.hs
View File

@ -13,7 +13,7 @@ import Data.List (intercalate, foldl1')
import Data.Time.Clock.POSIX (getPOSIXTime) import Data.Time.Clock.POSIX (getPOSIXTime)
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Exception (try, SomeException) import Control.Exception (try, SomeException)
import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent (ThreadId, forkIO, threadDelay, killThread)
import Control.Concurrent.STM (atomically) import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TVar (TVar, newTVarIO, readTVar, writeTVar) import Control.Concurrent.STM.TVar (TVar, newTVarIO, readTVar, writeTVar)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
@ -40,6 +40,7 @@ data Value = IntV Integer
| ListV [Value] | ListV [Value]
| DictV (M.Map Value Value) | DictV (M.Map Value Value)
| RefV (TVar Value) | RefV (TVar Value)
| Thread ThreadId
| Builtin BIF | Builtin BIF
| FnV Env [(Pattern, AST)] -- closure pattern->body bindings | FnV Env [(Pattern, AST)] -- closure pattern->body bindings
deriving (Eq) deriving (Eq)
@ -86,6 +87,7 @@ instance Show Value where
show (StreamV _) = "<stream>" show (StreamV _) = "<stream>"
show (Builtin _) = "<built-in>" show (Builtin _) = "<built-in>"
show (RefV _) = "<ref>" show (RefV _) = "<ref>"
show (Thread t) = "<thread " ++ show t ++ ">"
-- value operators -- value operators
(IntV l) +$ (IntV r) = IntV (l + r) (IntV l) +$ (IntV r) = IntV (l + r)
@ -203,10 +205,12 @@ _eval _ = error "eval: invalid args (want code and environment)"
_thread f@FnV{} = do _thread f@FnV{} = do
state <- get state <- get
liftIO $ forkIO $ (evalStateT (apply f unitv) state >> return ()) fmap Thread $ liftIO $ forkIO $ (evalStateT (apply f unitv) state >> return ())
return unitv
_thread _ = error "thread!: need a function" _thread _ = error "thread!: need a function"
_kill (Thread thread) = liftIO (killThread thread) >> return unitv
_kill _ = error "kill!: need a thread"
-- returns a dictionary of a new environment with only the standard -- returns a dictionary of a new environment with only the standard
-- default-imported functions -- default-imported functions
_newStdEnv (TupleV []) = do _newStdEnv (TupleV []) = do
@ -280,6 +284,7 @@ initialState = [M.fromList $ map (\(k,v) -> (T.pack k, v)) $ [
("locals", bif _locals), ("locals", bif _locals),
("newStdEnv", bif _newStdEnv), ("newStdEnv", bif _newStdEnv),
("thread!", bif _thread), ("thread!", bif _thread),
("kill!", bif _kill),
("eval", bif _eval), ("eval", bif _eval),
("import", bif _Import)]] ("import", bif _Import)]]