Create a gist now

Instantly share code, notes, and snippets.

@ijp /SECD.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 = ID Name
| Fun Name Expr
| Apply Expr Expr
deriving (Eq, Show)
data Value = S Name
| Closure Name Expr Environment
deriving (Eq, Show)
type Stack = [Value]
type Environment = [(Name, Value)]
data Controllee = AP
| AE Expr
deriving (Show)
type Control = [Controllee]
data Dump = Dump Stack Environment Control Dump
| InitState
deriving (Show)
lookup :: Name -> Environment -> Value
lookup n [] = S n
lookup n ((k,v):kvs)
| n == k = v -- The wrong thing (tm), but it makes things slightly easier to test
| otherwise = lookup n kvs
transform :: Stack -> Environment -> Control -> Dump -> Value
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 (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 (s1:s2:ss) e (AP : cs) d = transform (basicApply s1 s2:ss) e cs d
transform _ _ _ _ = error "crash"
-- Implement this to be handle primitive functions in the machine
basicApply :: Value -> Value -> Value
basicApply fun arg = error "not implemented yet"
runSECD :: [Expr] -> Value
runSECD es = transform [] initEnv initControl InitState
where initEnv = []
initControl = map AE es
test1 = runSECD [Apply (Fun "x" (ID "x")) (ID "y")] == S "y"
test2 = runSECD [Apply (Fun "x" (ID "x")) $ Apply (Fun "x" (ID "x")) (ID "y")] == S "y"
test3 = runSECD [Apply (Apply (Fun "x" (ID "x")) (Fun "x" (ID "x"))) (ID "y")] == S "y"
runTests = and [test1,test2,test3]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment