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