Think Stitch
PRINCIPIA  最近の更新


LispKit Lisp

LispKit Lisp を Gauche で書いてみました.

LispKit Lisp は SECD 機械という仮想機械をターゲットにした小さな Lisp 処理系です.LispKit Lisp と SECD 機械については以下の本に解説があります.

前準備

SECD 機械で命令のディスパッチをきれいに書くためにパターンマッチを使います.

それから,Scheme ではなくて Lisp なので,関数 eq と atom を用意しておきます.加えてオリジナルの ListKit Lisp にはシンボルと整数を区別する述語がないのですけど,遊ぶときに困るかもしれないので symbolp と integerp も用意しておきます.

(use util.match)

(define (eq x y) (eq? x y))
(define (atom x) (not (pair? x)))
(define (symbolp x) (symbol? x))
(define (integerp x) (integer? x))

仮想機械の命令は制御の基本となるものが 9個(非決定的計算を入れる場合は +2個),後は組み込み関数用のプリミティブ命令が 10数個あるだけです.オリジナルの LispKit Lisp では各命令に整数を割り当ててハードコードしているのですけど,さすがに読みにくいのでここではシンボルを使うことにします.ただ,あとで整数に切り替えられるように,ちょっと原始的ですけどグローバル変数に命令を入れておくことにします.

(define LD 'LD)
(define LDC 'LDC)
(define LDF 'LDF)
(define AP 'AP)
(define RTN 'RTN)
(define DUM 'DUM)
(define RAP 'RAP)
(define SEL 'SEL)
(define JOIN 'JOIN)
(define SOR 'SOR)
(define NON 'NON)
(define CAR 'CAR)
(define CDR 'CDR)
(define CONS 'CONS)
(define ATOM 'ATOM)
(define EQ 'EQ)
(define SYMBOLP 'SYMBOLP)
(define INTEGERP 'INTEGERP)
(define LESS 'LESS)
(define ADD 'ADD)
(define SUB 'SUB)
(define MUL 'MUL)
(define DIV 'DIV)
(define REM 'REM)

SECD 仮想機械

(define (vm s e c d)
  (match c
    (()
     (if (null? d)
         (car s)
         ;; RTN
         (match d
           ((s2 e2 c2 . d2)
            (vm (cons (car s) s2) e2 c2 d2)))))
    (('LD i . c)
     (vm (cons (locate i e) s) e c d))
    (('LDC x . c)
     (vm (cons x s) e c d))
    (('LDF cf . c)
     (vm (cons (cons cf e) s) e c d))
    (('AP . c)
     (match s
       (((cf . e2) v . s2)
        (vm '() (cons v e2) cf (cons* s2 e c d)))))
    (('RTN)
     (match d
       ((s2 e2 c2 . d2)
        (vm (cons (car s) s2) e2 c2 d2))))
    (('DUM . c)
     (vm s (cons '() e) c d))
    (('RAP . c)
     (match s
       (((cf . e2) v . s)
        (set-car! e2 v)
        (vm '() e2 cf (cons* s (cdr e) c d)))))
    (('SEL ct cf . c)
     (vm (cdr s) e (if (not (null? (car s))) ct cf) (cons c d)))
    (('JOIN)
     (vm s e (car d) (cdr d)))

    (('CAR . c)
     (vm (cons (car (car s)) (cdr s)) e c d))
    (('CDR . c)
     (vm (cons (cdr (car s)) (cdr s)) e c d))
    (('CONS . c)
     (vm (cons (cons (car s) (cadr s)) (cddr s)) e c d))
    (('EQ . c)
     (vm (cons (if (eq? (cadr s) (car s)) 't '()) (cddr s)) e c d))
    (('LESS . c)
     (vm (cons (if (< (cadr s) (car s)) 't '()) (cddr s)) e c d))
    (('ADD . c)
     (vm (cons (+ (cadr s) (car s)) (cddr s)) e c d))
    (('SUB . c)
     (vm (cons (- (cadr s) (car s)) (cddr s)) e c d))
    (('ATOM . c)
     (vm (cons (if (atom (car s)) 't '()) (cdr s)) e c d))
    (('SYMBOLP . c)
     (vm (cons (if (symbolp (car s)) 't '()) (cdr s)) e c d))
    (('INTEGERP . c)
     (vm (cons (if (integerp (car s)) 't '()) (cdr s)) e c d))
    (else
     (error "unknown instruction" s e c d))))

コンパイラ

(define compile
  (letrec
      ((compile
        (lambda (e)
          (comp e '() '())))
       (comp
        (lambda (e n c)
          (cond ((symbolp e)
                 (cons LD (cons (location e n) c)))
                ((atom e)
                 (cons LDC (cons e c)))
                ((eq (car e) 'quote)
                 (cons LDC (cons (car (cdr e)) c)))
                ((eq (car e) '+)
                 (comp (car (cdr e)) n
                       (comp (car (cdr (cdr e))) n
                             (cons ADD c))))
                ((eq (car e) '-)
                 (comp (car (cdr e)) n
                       (comp (car (cdr (cdr e))) n
                             (cons SUB c))))
                ((eq (car e) 'eq)
                 (comp (car (cdr e)) n
                       (comp (car (cdr (cdr e))) n
                             (cons EQ c))))
                ((eq (car e) '<)
                 (comp (car (cdr e)) n
                       (comp (car (cdr (cdr e))) n
                             (cons LESS c))))
                ((eq (car e) 'cons)
                 (comp (car (cdr (cdr e))) n
                       (comp (car (cdr e)) n
                             (cons CONS c))))
                ((eq (car e) 'car)
                 (comp (car (cdr e)) n (cons CAR c)))
                ((eq (car e) 'cdr)
                 (comp (car (cdr e)) n (cons CDR c)))
                ((eq (car e) 'atom)
                 (comp (car (cdr e)) n (cons ATOM c)))
                ((eq (car e) 'rd)
                 (cons RD c))
                ((eq (car e) 'wr)
                 (comp (car (cdr e)) n (cons WR c)))
                ((eq (car e) 'symbolp)
                 (comp (car (cdr e)) n (cons SYMBOLP c)))
                ((eq (car e) 'integerp)
                 (comp (car (cdr e)) n (cons INTEGERP c)))
                ((eq (car e) 'if)
                 (let ((ct (comp (car (cdr (cdr e))) n (cons JOIN '())))
                       (cf (comp (car (cdr (cdr (cdr e)))) n (cons JOIN '()))))
                   (comp (car (cdr e)) n
                         (cons SEL (cons ct (cons cf c))))))
                ((eq (car e) 'lambda)
                 (let ((cf (comp (car (cdr (cdr e)))
                                 (cons (car (cdr e)) n)
                                 (cons RTN '()))))
                   (cons LDF (cons cf c))))
                ((eq (car e) 'let)
                 (let ((m (cons (vars (car (cdr e))) n))
                       (args (exprs (car (cdr e)))))
                   (let ((body (comp (car (cdr (cdr e))) m
                                     (cons RTN '()))))
                     (complis args n (cons LDF (cons body (cons AP c)))))))
                ((eq (car e) 'letrec)
                 (let ((m (cons (vars (car (cdr e))) n))
                       (args (exprs (car (cdr e)))))
                   (let ((body (comp (car (cdr (cdr e))) m
                                     (cons RTN '()))))
                     (cons DUM (complis args m (cons LDF (cons body (cons RAP c))))))))
                ((eq (car e) 'exec)
                 (cons LDC
                       (cons '()
                             (cons LDC
                                   (cons '()
                                         (comp (car (cdr e)) n
                                               (cons CONS
                                                     (cons AP c))))))))
                ((eq (car e) 'cond)
                 (let ((x (expandcond (cdr e))))
                   (comp x n c)))
                (else
                 (complis (cdr e) n
                          (comp (car e) n
                                (cons AP c)))))))
       (complis
        (lambda (e n c)
          (if (eq e '())
              (cons LDC (cons '() c))
              (complis (cdr e) n (comp (car e) n (cons CONS c))))))
       (expandcond
        (lambda (cs)
          (cond ((eq cs '()) '())
                ((eq (car (car cs)) 'else)
                 (car (cdr (car cs))))
                (else
                 (cons 'if
                       (cons (car (car cs))
                             (cons (car (cdr (car cs)))
                                   (cons (expandcond (cdr cs)) '()))))))))
       (position
        (lambda (x a)
          (if (eq x (car a))
              0
              (+ 1 (position x (cdr a))))))
       (location
        (lambda (x n)
          (if (member x (car n))
              (cons 0 (position x (car n)))
              (let ((z (location x (cdr n))))
                (cons (+ 1 (car z)) (cdr z))))))
       (member
        (lambda (x a)
          (cond ((eq a '()) #f)
                ((eq x (car a)) 't)
                (else
                 (member x (cdr a))))))
       (vars
        (lambda (e)
          (if (eq e '())
              '()
              (cons (car (car e)) (vars (cdr e))))))
       (exprs
        (lambda (e)
          (if (eq e '())
              '()
              (cons (car (cdr (car e))) (exprs (cdr e)))))))
    compile))

実行例

コンパイラでコンパイルしたコードを仮想機械に渡して実行できます.

(vm '() '()
    (compile
     '(letrec ((rev (lambda (x y)
                      (if (atom x)
                          y
                          (rev (cdr x) (cons (car x) y))))))
        (rev '(0 1 2 3 4 5 6 7) '())))
    '())
=> (7 6 5 4 3 2 1 0)

ベンチマークでよく使う,わざと効率悪く書いた append と reverse です.

(vm '() '()
    (compile
     '(letrec ((rev (lambda (x)
                      (if (atom x)
                          '()
                          (app (rev (cdr x))
                               (cons (car x) '())))))
               (app (lambda (x y)
                      (if (atom x)
                          y
                          (app (rev (cdr (rev x)))
                               (cons (car (rev x)) y))))))
        (rev '(0 1 2 3 4 5 6 7))))
    '())
=> (7 6 5 4 3 2 1 0)

セルフコンパイル

このコンパイラで,コンパイラ自身をコンパイルします.

(define c0
  (compile
   '(letrec
        ((compile
          (lambda (e)
            (comp e '() '())))
         ......
         (exprs
          (lambda (e)
            (if (eq e '())
                '()
                (cons (car (cdr (car e))) (exprs (cdr e)))))))
      compile)))

このコンパイラ自信でコンパイルしたコンパイラを仮想機械で動かして,コンパイラ自身をコンパイルします.

(define c1
  (vm '() '()
      (compile
       '(letrec
            ((compile
              (lambda (e)
                (comp e '() '())))
             ......
             (exprs
              (lambda (e)
                (if (eq e '())
                    '()
                    (cons (car (cdr (car e))) (exprs (cdr e)))))))
          (compile
           '(letrec
                ((compile
                  (lambda (e)
                    (comp e '() '())))
                 ......
                 (exprs
                  (lambda (e)
                    (if (eq e '())
                        '()
                        (cons (car (cdr (car e))) (exprs (cdr e)))))))
              compile))))
      '()))

2つの結果は一致します (^^).

(equal? c0 c1)
=> #t
2015/03/22
© 2013,2014,2015 PRINCIPIA Limited