Haskell で SECD マシン

どこかにバグがあるけど何とか関数適用まで動くようになったので貼付けておく。

• 「:.」は「.」のつもりのデータ構築子。

-- SECD Machine
data SECD = SECD LispVal LispVal LispVal LispVal
            deriving (Eq, Show)

step (SECD s e (LDC x :. c) d) = SECD (x :. s) e c d
step (SECD s e (NIL :. c) d) = SECD (Nil :. s) e c d

-- (+ a b) => LDC b LDC a Op +
step (SECD (a :. b :. s) e (Op "+" :. c) d) = SECD (binOp (+) a b :. s) e c d
-- (- a b) => LDC b LDC a Op -
step (SECD (a :. b :. s) e (Op "-" :. c) d) = SECD (binOp (-) a b :. s) e c d
step (SECD (a :. b :. s) e (Op "*" :. c) d) = SECD (binOp (*) a b :. s) e c d
step (SECD (a :. b :. s) e (Op ">" :. c) d) = SECD (fn a b :. s) e c d
    where fn (Number a) (Number b) = Bool (a > b)
step (SECD (a :. b :. s) e (Op "<" :. c) d) = SECD (fn a b :. s) e c d
    where fn (Number a) (Number b) = Bool (a < b)
step (SECD (x :. s) e (SEL :. ct :. cf :. c) d) = SECD s e c' (c :. d)
    where c' = if x == Bool True
               then
                   ct
               else
                   cf
step (SECD s e (JOIN :. c) (cr :. d)) = SECD s e cr d
step (SECD s e (LDF f :. c) d) = SECD ((f :. e) :. s) e c d
-- (cons a b) => ldc b ldc a cons, stack = a b . s
step (SECD (a :. b :. s) e (CONS :. c) d) = SECD ((a :. b) :. s) e c d
step (SECD ((f :. e') :. v :. s) e (AP :. c) d) = SECD Nil (v :. e') f (s :. e :. c :. d)
step (SECD (x :. z) e' (RTN :. q) (s :. e :. c :. d)) = SECD (x :. s) e c d
step (SECD s e (LD (i, j) :. c) d) = SECD ((locate (i,j) e) :. s) e c d
    where
      locate (i,j) e = (lispNth j (lispNth i e))
step (SECD s e c d) = SECD s e c d

runSecd = fixpoint step
readAndRun str = runSecd (SECD (Atom "s") (Atom "e") (comp (readExpr str)) (Atom "d"))
readAndRun' str = showLispVal $ car s
    where
      SECD s e c d = readAndRun str