`(Hello ,world)

ツッコミ、添削大歓迎です。いろいろ教えてください。

2008-04-11

バイトコンパイル(3)

08:27

バイトコンパイル(2)の続き。lambda式の生成、適用。リストのコンパイル処理で、先頭が 'lambda だったら lambda 式:

;; リスト
(defun comp-list (s nxt)
  (case (car s)
    ...
    (lambda    (comp-lambda s nxt))
    ...

「:close (変数リスト 本体)」というバイトコードを作成:

;; lambda 式
(defun comp-lambda (s nxt)
  (let ((body (reduce (lambda (nx b)
                        (compile b nx))
                      (reverse (cddr s))
                      :initial-value `(:return)))
        (params (cadr s)))
    (append `(:close (,params ,@body)) nxt)))

コンパイルテスト:

> (compile
   '(lambda (x) x)
   nil)
(:close ((x) :refer x :return))

VMに :close の処理を追加。その時点での環境を含め、(:close 環境 変数リスト 本体) をスタックに積む:

(defun step-vm (stack env code dump)
  (case (car code)
    ...
    (:close (let ((params-body (cadr code)))
              (values (cons `(:close ,env ,@params-body) stack) env (cddr code) dump)))
    ...

関数適用するときに、:close だったら lambda 式の呼び出し。引数関数ローカル変数にバインドした新しい環境を作り、戻る先のコードを dump に退避して、lambda 式の本体コードに飛ぶ:

(defun step-vm (stack env code dump)
  (case (car code)
    ...
    (:apply (let ((fn (car stack))
                  (args (cdr stack)))
              (cond
                    ...
                    ((and (consp fn) (eq (car fn) :close))
                     (let* ((fenv (cadr fn))
                            (params (caddr fn))
                            (body (cdddr fn))
                            (new-env (cons (bind-args params args) fenv)))
                       (values '() new-env body (append (list '() (cdr code)) dump)))) 
                    ...

引数のバインド:alist の作成

(defun bind-args (params args)
  (if (null params)
      '()
    (if (consp params)
        (cons (cons (car params) (car args))
              (bind-args (cdr params) (cdr args)))
      (cons (cons params args)
            nil))))

環境を単一の alist じゃなくて、alist のリストにした。ので、lookup で alist をたどるように修正:

(defun lookup (symb env)
  (if (null env)
      (error "undefined symbol: ")
    (let ((pair (assoc symb (car env))))
      (if pair
          (cdr pair)
        (lookup symb (cdr env))))))

デフォルトの環境も修正:

(defun init-env ()
  (list
   (list
    (cons 'nil 'nil)
    (cons 't   't)
    (cons 'cons (lambda (a d) (cons a d)))
    (cons 'car  (lambda (c) (car c)))
    (cons 'cdr  (lambda (c) (cdr c)))
    (cons '+ (lambda (&rest args) (apply #'+ args)))
    (cons '* (lambda (&rest args) (apply #'* args)))
    (cons 'eq (lambda (a b) (eq a b)))
    )))

実行テスト:

> (run-vm
   (compile 
    '((lambda (x) x) 1234) 
    nil) 
   (init-env))

(:frame (:const 1234 :close ((x) :refer x :return) :apply :return)) 
(:const 1234 :close ((x) :refer x :return) :apply :return) 
(:close ((x) :refer x :return) :apply :return) 
(:apply :return) 
(:refer x :return) 
(:return) 
(:return) 
"**** RESULT ****" 
(1234) 
nil 
1234

クロージャのテスト:

> (run-vm
   (compile 
    '(((lambda (n) (lambda (x) (+ x n))) 1) 10) 
    nil) 
   (init-env))

(:frame (:const 10 :frame (:const 1 :close ((n) :close ((x) :refer n :refer x :refer + :apply :return) :return) :apply :return) :apply :return)) 
(:const 10 :frame (:const 1 :close ((n) :close ((x) :refer n :refer x :refer + :apply :return) :return) :apply :return) :apply :return) 
(:frame (:const 1 :close ((n) :close ((x) :refer n :refer x :refer + :apply :return) :return) :apply :return) :apply :return) 
(:const 1 :close ((n) :close ((x) :refer n :refer x :refer + :apply :return) :return) :apply :return) 
(:close ((n) :close ((x) :refer n :refer x :refer + :apply :return) :return) :apply :return) 
(:apply :return) 
(:close ((x) :refer n :refer x :refer + :apply :return) :return) 
(:return) 
(:return) 
(:apply :return) 
(:refer n :refer x :refer + :apply :return) 
(:refer x :refer + :apply :return) 
(:refer + :apply :return) 
(:apply :return) 
(:return) 
(:return) 
"**** RESULT ****" 
(11) 
nil 
11
トラックバック - http://cadr.g.hatena.ne.jp/mokehehe/20080411