SECD.hs

-- 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]