secd machine compiler

まだテスト不足だけど secd machine 用コンパイラを書いた。一応以下のような再帰関数も書けて、ちゃんと VM で動く。いまさらだけど、グローバルな束縛が無いにも関わらず、再帰計算(のような計算。正確な名前は知らない)ができるのは面白い。

gosh> (print (compile () '((lambda (o e n)
                (o o e n))
              (lambda (o e x)
                (if (= x 0)
                    "even"
                    (e o e (- x 1))))
              (lambda (o e x)
                (if (= x 0)
                    "odd"
                    (o o e (- x 1))))
              12)))
(NIL LDC 12 CONS LDF (LDC 0 LD (1 . 3) = SEL (LDC odd JOIN) (NIL LDC 1 LD (1 . 3) - CONS LD (1 . 2) CONS LD (1 . 1) CONS LD (1 . 1) AP JOIN) RTN) CONS LDF (LDC 0 LD (1 . 3) = SEL (LDC even JOIN) (NIL LDC 1 LD (1 . 3) - CONS LD (1 . 2) CONS LD (1 . 1) CONS LD (1 . 2) AP JOIN) RTN) CONS LDF (NIL LD (1 . 3) CONS LD (1 . 2) CONS LD (1 . 1) CONS LD (1 . 1) AP RTN) AP)

gosh> (run '((lambda (f n)
                (if (= n 0)
                    1
                    (* n (f f (- n 1)))))
             (lambda (f n)
                (if (= n 0)
                    1
                    (* n (f f (- n 1)))))
             10))
;; (3628800 . s) e c d

次はステップ毎の処理を丁寧に書き下して、どこらへんが gauche vm と同じでどこらへんが違っているかを見てみよう。Tail recursive SECD Machine も。

以下コード。

(define (lookup env var) ;; return (level . index)
  (let loop ((e env) (level 1))
    (if (null? (car e))
        (errorf "fail to lookup: var ~a in env ~a" e env)
        (let1 found (assoc var (car e))
          (if found
              (cons level (cdr found))
              (loop (cdr e) (+ level 1)))))))

(define (extend-env env plist)
  (append (list (map (lambda (var n)
                       (cons var n))
                     plist
                     (iota (length plist) 1)))
          env))

(define (compile env exp)
  (cond
   ((eq? exp 'NIL)
    'NIL)
   ((number? exp)
    `(LDC ,exp))
   ((boolean? exp)
    `(LDC ,exp))
   ((string? exp)
    `(LDC ,exp))
   ((symbol? exp)
    `(LD ,(lookup env exp)))
   (else
    (match exp
      (('atom a)
       `(,@(compile env a) ATOM))
      (('+ a b)
       `(,@(compile env b) ,@(compile env a) +))
      (('- a b)
       `(,@(compile env b) ,@(compile env a) -))
      (('= a b)
       `(,@(compile env b) ,@(compile env a) =))
      (('* a b)
       `(,@(compile env b) ,@(compile env a) *))
      (('> a b)
       `(,@(compile env b) ,@(compile env a) >))
      (('< a b)
       `(,@(compile env b) ,@(compile env a) <))
      (('if e1 e2 e3)
       `(,@(compile env e1) SEL (,@(compile env e2) JOIN) (,@(compile env e3) JOIN)))
      (('lambda plist body)
       `(LDF ,(append (compile (extend-env env plist) body) '(RTN))))
      ((e)
       `(NIL ,@(compile env e) AP))
      ((e e1)
       `(NIL ,@(compile env e1) CONS ,@(compile env e) AP))
      ((e ek ...)
       `(NIL
         ,@(append-map (lambda (en)
                         (append (compile env en) '(CONS))) (reverse ek))
         ,@(compile env e) AP))))))