Create a gist now

Instantly share code, notes, and snippets.

@ijp /SECD2.hs
Created Feb 18, 2013

What would you like to do?
-- An implementation of Peter Landin's SECD machine, as described in
-- "The Mechanical Evaluate of Expressions"
import Prelude hiding (lookup)
type Name = String
data Expr a = ID Name
| Obj a
| Fun Name (Expr a)
| Apply (Expr a) (Expr a)
deriving (Eq, Show)
data Value a = S Name
| Closure Name (Expr a) (Environment a)
| PrimFunc Name (Value a -> Value a)
| V a
instance Eq a => Eq (Value a) where
S n == S m = m == n
V a == V b = a == b
_ == _ = False
instance Show a => Show (Value a) where
show (S n) = "S " ++ show n
show (Closure _ _ _) = "#<Closure>"
show (PrimFunc f _) = "#<primfunc " ++ f ++ ">"
show (V a) = "V " ++ show a
type Stack a = [Value a]
type Environment a = [(Name, Value a)]
data Controllee a = AP
| AE (Expr a)
deriving (Show)
type Control a = [Controllee a]
data Dump a = Dump (Stack a) (Environment a) (Control a) (Dump a)
| InitState
deriving (Show)
lookup :: Name -> Environment a -> Value a
lookup n [] = error $ "Not found: "
lookup n ((k,v):kvs)
| n == k = v
| otherwise = lookup n kvs
transform :: Stack a -> Environment a -> Control a -> Dump a -> Value a
transform (s:_) e [] InitState = s
transform (s:ss) e [] (Dump s' e' c' d') = transform (s:s') e' c' d'
transform s e (AE (ID i):cs) d = transform (lookup i e : s) e cs d
transform s e (AE (Obj o):cs) d = transform (V o : s) e cs d
transform s e (AE (Fun n b) : cs) d = transform (Closure n b e : s) e cs d
transform s e (AE (Apply op arg) : cs) d = transform s e (AE arg : AE op : AP : cs) d
transform (Closure n b e' : s2 : ss) e (AP : cs) d = transform [] e'' [AE b] d'
where e'' = (n, s2) : e'
d' = Dump ss e cs d
transform (PrimFunc _ f:s2:ss) e (AP : cs) d = transform (f s2:ss) e cs d
transform _ _ _ _ = error "crash"
runSECD' :: Environment a -> [Expr a] -> Value a
runSECD' initEnv es = transform [] initEnv initControl InitState
where initControl = map AE es
runSECD :: [Expr a] -> Value a
runSECD = runSECD' []
test1 = runSECD [Apply (Fun "x" (ID "x")) (Obj 3)] == V 3
test2 = runSECD [Apply (Fun "x" (ID "x")) $ Apply (Fun "x" (ID "x")) (Obj 3)] == V 3
test3 = runSECD [Apply (Apply (Fun "x" (ID "x")) (Fun "x" (ID "x"))) (Obj 3)] == V 3
liftPrim :: Name -> (a -> a) -> Value a
liftPrim name f = PrimFunc name f'
where f' (V a) = V (f a)
f' _ = error $ "primitive error: " ++ name
liftPrim2 :: Name -> (a -> a -> a) -> Value a
liftPrim2 name f = PrimFunc name f'
where f' (V a) = PrimFunc (name ++ "(partial)") (g' a)
f' _ = error $ "primitive error: " ++ name
g' a (V b) = V (f a b)
g' _ _ = error $ "primitive error: " ++ name
intEnv = [("succ", liftPrim "succ" (\x -> x + 1)),
("pred", liftPrim "pred" (\y -> y - 1)),
("+", liftPrim2 "+" (+)),
("-", liftPrim2 "-" (-)),
("*", liftPrim2 "*" (*))]
test4 = runSECD' intEnv [Apply (ID "succ") $ Apply (ID "succ") (Obj 3)] == V 5
test5 = runSECD' intEnv [Apply fun1 fun2] == V 5
where fun1 = (Fun "g" (Apply (Apply (ID "-") (Apply (ID "g") (ID "*")))
(Apply (ID "g") (ID "+"))))
fun2 = (Fun "f" (Apply (Apply (ID "f") (Obj 3)) (Obj 4)))
runTests = and [test1,test2,test3, test4, test5]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment