transition to linked lexical environments
This commit is contained in:
parent
a6cdb3b073
commit
639b5646e0
49
interp.hs
49
interp.hs
|
@ -25,24 +25,32 @@ data Value = IntV Integer
|
||||||
| TupleV [Value]
|
| TupleV [Value]
|
||||||
| ListV [Value]
|
| ListV [Value]
|
||||||
| Builtin BIF
|
| Builtin BIF
|
||||||
| FnV [(Pattern, AST)] -- pattern->body bindings
|
| FnV Env [(Pattern, AST)] -- closure pattern->body bindings
|
||||||
deriving (Eq)
|
deriving (Eq)
|
||||||
|
|
||||||
type Env = M.Map String Value -- an environment
|
type Env = [M.Map String Value] -- lexical environment (linked list)
|
||||||
type InterpState = StateT ([Handle], Env) IO -- interpreter state (open handles, global env)
|
type InterpState = StateT ([Handle], Env) IO -- interpreter state (open handles, global env)
|
||||||
|
|
||||||
lookup :: Env -> String -> Maybe Value
|
emptyEnv = [M.empty]
|
||||||
lookup env name = M.lookup name env
|
|
||||||
|
|
||||||
|
-- look up a binding from the bottom up
|
||||||
|
lookup :: Env -> String -> Maybe Value
|
||||||
|
lookup [] _ = Nothing
|
||||||
|
lookup (env:xs) name =
|
||||||
|
case M.lookup name env of
|
||||||
|
Nothing -> lookup xs name
|
||||||
|
Just x -> Just x
|
||||||
|
|
||||||
|
-- bind in the local environment
|
||||||
bind :: Env -> String -> Value -> Env
|
bind :: Env -> String -> Value -> Env
|
||||||
bind env name value = M.insert name value env
|
bind (env:xs) name value = (M.insert name value env):xs
|
||||||
|
|
||||||
instance Show Value where
|
instance Show Value where
|
||||||
show (IntV i) = show i
|
show (IntV i) = show i
|
||||||
show (StrV s) = show s
|
show (StrV s) = show s
|
||||||
show (TupleV v) = "(" ++ intercalate "," (map show v) ++ ")"
|
show (TupleV v) = "(" ++ intercalate "," (map show v) ++ ")"
|
||||||
show (ListV v) = show v
|
show (ListV v) = show v
|
||||||
show (FnV _) = "<fn>"
|
show (FnV _ _) = "<fn>"
|
||||||
show (StreamV _) = "<stream>"
|
show (StreamV _) = "<stream>"
|
||||||
show (Builtin _) = "<built-in>"
|
show (Builtin _) = "<built-in>"
|
||||||
show UnitV = "()"
|
show UnitV = "()"
|
||||||
|
@ -79,13 +87,13 @@ _itos (IntV i) = return $ StrV $ show i
|
||||||
_itos v = error $ "itos: not an int: " ++ show v
|
_itos v = error $ "itos: not an int: " ++ show v
|
||||||
|
|
||||||
initialState = ([stdout, stdin],
|
initialState = ([stdout, stdin],
|
||||||
M.fromList [("id", FnV [(VarP "x", Var "x")]),
|
[M.fromList [("id", FnV emptyEnv [(VarP "x", Var "x")]),
|
||||||
("stdout", StreamV 0),
|
("stdout", StreamV 0),
|
||||||
("putstr", Builtin $ BIF _putstr),
|
("putstr", Builtin $ BIF _putstr),
|
||||||
("putstrln", Builtin $ BIF (\x -> _putstr $ x +$ StrV "\n")),
|
("putstrln", Builtin $ BIF (\x -> _putstr $ x +$ StrV "\n")),
|
||||||
("print", Builtin $ BIF _print),
|
("print", Builtin $ BIF _print),
|
||||||
("itos", Builtin $ BIF _itos),
|
("itos", Builtin $ BIF _itos),
|
||||||
("getline", Builtin $ BIF _getline)])
|
("getline", Builtin $ BIF _getline)]])
|
||||||
|
|
||||||
eval :: AST -> InterpState Value
|
eval :: AST -> InterpState Value
|
||||||
|
|
||||||
|
@ -121,9 +129,9 @@ eval (Defun name fn) = do
|
||||||
eval fn >>= \fn' ->
|
eval fn >>= \fn' ->
|
||||||
put (s, bind env name fn') >> return fn'
|
put (s, bind env name fn') >> return fn'
|
||||||
Just oldfn -> -- add pattern to old fn
|
Just oldfn -> -- add pattern to old fn
|
||||||
let FnV oldpats = oldfn
|
let FnV cls oldpats = oldfn
|
||||||
Lambda [(pat, body)] = fn
|
Lambda [(pat, body)] = fn
|
||||||
newfn = FnV (oldpats ++ [(pat, body)]) in
|
newfn = FnV cls (oldpats ++ [(pat, body)]) in
|
||||||
put (s, bind env name newfn) >> return newfn
|
put (s, bind env name newfn) >> return newfn
|
||||||
|
|
||||||
eval (Def name v') = do
|
eval (Def name v') = do
|
||||||
|
@ -133,22 +141,28 @@ eval (Def name v') = do
|
||||||
return v
|
return v
|
||||||
|
|
||||||
eval (Lambda pats) =
|
eval (Lambda pats) =
|
||||||
return $ FnV pats
|
get >>= \(_,env) ->
|
||||||
|
return $ FnV env pats
|
||||||
|
|
||||||
eval (Add l r) = do { l <- eval l; r <- eval r; return $ l +$ r }
|
eval (Add l r) = do { l <- eval l; r <- eval r; return $ l +$ r }
|
||||||
eval (Sub l r) = do { l <- eval l; r <- eval r; return $ l -$ r }
|
eval (Sub l r) = do { l <- eval l; r <- eval r; return $ l -$ r }
|
||||||
eval (Mul l r) = do { l <- eval l; r <- eval r; return $ l *$ r }
|
eval (Mul l r) = do { l <- eval l; r <- eval r; return $ l *$ r }
|
||||||
eval (Div l r) = do { l <- eval l; r <- eval r; return $ l /$ r }
|
eval (Div l r) = do { l <- eval l; r <- eval r; return $ l /$ r }
|
||||||
|
|
||||||
eval (Call name arg) = get >>= \(_,env) ->
|
eval (Call name arg) = get >>= \(h,env) ->
|
||||||
case lookup env name of
|
case lookup env name of
|
||||||
Just fn@(FnV _) -> eval arg >>= apply fn
|
Just fn@(FnV cls _) -> do
|
||||||
|
arg' <- eval arg
|
||||||
|
put (h,cls) -- enter closure env
|
||||||
|
let v = apply fn arg'
|
||||||
|
put (h,env) -- restore env
|
||||||
|
v
|
||||||
Just fn@(Builtin _) -> eval arg >>= apply fn
|
Just fn@(Builtin _) -> eval arg >>= apply fn
|
||||||
Nothing -> error $ "call: name " ++ name ++ " doesn't exist or is not a function"
|
Nothing -> error $ "call: name " ++ name ++ " doesn't exist or is not a function"
|
||||||
|
|
||||||
eval x = error $ "eval: unhandled: " ++ show x
|
eval x = error $ "eval: unhandled: " ++ show x
|
||||||
|
|
||||||
patternBindings :: Pattern -> Value -> Maybe Env
|
patternBindings :: Pattern -> Value -> Maybe (M.Map String Value)
|
||||||
patternBindings (VarP n) v = Just $ M.fromList [(n, v)]
|
patternBindings (VarP n) v = Just $ M.fromList [(n, v)]
|
||||||
|
|
||||||
patternBindings (IntP n) (IntV v)
|
patternBindings (IntP n) (IntV v)
|
||||||
|
@ -191,16 +205,17 @@ patternBindings (TupleP _) _ = Nothing -- not a tuple
|
||||||
|
|
||||||
-- applies a function
|
-- applies a function
|
||||||
apply :: Value -> Value -> InterpState Value
|
apply :: Value -> Value -> InterpState Value
|
||||||
apply (FnV pats) arg =
|
apply (FnV _ pats) arg =
|
||||||
apply' pats
|
apply' pats
|
||||||
where
|
where
|
||||||
apply' [] = error $ "argument " ++ show arg ++ " doesn't satisfy any patterns"
|
apply' [] = error $ "argument " ++ show arg ++ " doesn't satisfy any patterns"
|
||||||
apply' ((pat, body):xs) =
|
apply' ((pat, body):xs) =
|
||||||
case patternBindings pat arg of
|
case patternBindings pat arg of
|
||||||
Just env' -> -- satisfies
|
Just bindings -> -- satisfies
|
||||||
do
|
do
|
||||||
(s,env) <- get
|
(s,env) <- get
|
||||||
put (s, M.union env' env)
|
let newenv = bindings:env
|
||||||
|
put (s, newenv)
|
||||||
eval body
|
eval body
|
||||||
Nothing -> -- doesn't satisfy this pattern
|
Nothing -> -- doesn't satisfy this pattern
|
||||||
apply' xs
|
apply' xs
|
||||||
|
|
Loading…
Reference in New Issue