`(Hello ,world)

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

2008-04-10

バイトコンパイル(2)

07:22

バイトコンパイルの続き。組込みの関数適用を追加:

;; 関数適用
(defun comp-apply (s nxt)
  (let ((fn (car s))
        (args (cdr s)))
      (if (not (eq (car nxt) :return))
          (append `(:frame ,(comp-apply-call fn args '(:return))) nxt)
        (comp-apply-call fn args nxt))))
; 関数の呼び出し:引数をスタックにつんで :apply
(defun comp-apply-call (fn args nxt)
  (reduce (lambda (nx b)
            (compile b nx))
          args
          :initial-value (compile fn (cons :apply nxt))))

コンパイルテスト:

> (compile 
   '(+ 1 2) 
   nil) 
(:frame (:const 2 :const 1 :refer + :apply :return)) 

vm のほうにも処理を追加。「:frame」で始まって引数スタックに積んでいき、「:apply」で呼び出し:

(defun step-vm (stack env code dump)
    ...
    (:frame (let ((c   (cadr code))
                  (nxt (cddr code)))
              (values '() env c (append (list stack nxt) dump)))) 
    (:return (values (append stack (car dump)) env (cadr dump) (cddr dump)))
    (:apply (let ((fn (car stack))
                  (args (cdr stack)))
              (cond ((functionp fn)
                     (values (cons (apply fn args) '()) env (cdr code) dump))
                    (otherwise (error "Illegal apply: ")))))
    ...

環境に組込みの関数を追加する:

(defun init-env ()
  (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
    '(+ 1 2)
    nil)
   (init-env))

(:frame (:const 2 :const 1 :refer + :apply :return)) 
(:const 2 :const 1 :refer + :apply :return) 
(:const 1 :refer + :apply :return) 
(:refer + :apply :return) 
(:apply :return) 
(:return) 
"**** RESULT ****" 
(3) 
nil 
3
トラックバック - http://cadr.g.hatena.ne.jp/mokehehe/20080410