L.i.S.P 写経(その3)、4章

L.i.S.P 4章、疑問が残ってしまった、というのが一言感想です。

これまでの実装と大きく異なるのが、副作用を使わないということです。例えば set! の実装は以下のようになっています。

(define (evaluate-variable n r s k)
  (k (s (r n)) s))

...

(define (evaluate-set! n e r s k)
  (evaluate e r s
    (lambda (v ss)
      (k v (update ss (r n) v)))))

r は変更されていないことに注目することができます。そのかわりに、 ss が update されています。というわけで、メモリの実装を見ます。

(define (update s a v)
  (lambda (aa)
    (if (eqv? a aa) v (s aa))))

(define (update* s a* v*)
  (if (pair? a*)
    (update* (update s (car a*) (car v*)) (cdr a*) (cdr v*))
    s))

(define (allocate n s q)
  (if (> n 0)
    (let ((a (new-location s)))
      (allocate (- n 1)
                (expand-store a s)
                (lambda (a* ss)
                  (q (cons a a*) ss))))
    (q '() s)))

(define (expand-store high-location s)
  (update s 0 high-location))

(define (new-location s)
  (+ 1 (s 0)))

(define s.init
  (expand-store 0 (lambda (a) (wrong "No such address" a))))

ここの最初に出てくる update がクロージャを連ねてゆくことで、新たに確保されたアドレス a へ値 v が保持されます。同じアドレスに対してもクロージャが連ねられる、つまり、メモリへの変更が全て保持されていることになるので、本文中でも、明らかに過度なやり方だけれども、という記述があります。メモリというからには、例えば同じアドレスの中身は書き換えられそうな気がします。ただ、ここでは副作用をとことん避けるとしたらば、ということで話が進められているので、変更が全て保持されるというのが自然なこと（というかそれ以外にやりようが無いと思う）、ということになります。ということで納得します。

defprimitive で作った関数と、 definitial + set! で作った関数の扱いが微妙に異なってしまうけれども…そこが疑問です。

(begin
  (definitial ttmp (create-boolean #f))
  (evaluate '(begin (set! ttmp (lambda ()))) r.global s.global
    (lambda (v ss)
      (let* ((cons1 (r.global 'cons))
             (cons2 ((ss cons1) 'tag))
             (ttmp1 (r.global 'ttmp))
             (ttmp2 ((ss ttmp1) 'tag)))
        (values (list cons1 cons2)
                (list ttmp1 ttmp2))))))
;;=> (12 12), (50 51)

definitial + set! の場合、名前と関数に一つずつアドレスが確保されるのだけれども、 defprimitive では同じアドレスが使い回されています。なんでそうなるかは、 defprimitive も、 definitial も (allocate 1 s.global ...) として、どちも書き換えられる前の s.global を引数にアドレスを確保しているためと考えられます。それと、 defprimitive で (set! s.global (expand-store ...)) している所、どんな意図があるのか疑問です。

(define-syntax definitial
  (syntax-rules ()
    ((definitial name value)
     (allocate 1 s.global   ;; XXX: defprimitive にも注目
       (lambda (a* ss)
         (set! r.global (update r.global 'name (car a*)))
         (set! s.global (update ss (car a*) value)))))))

(define-syntax defprimitive
  (syntax-rules ()
    ((defprimitive name value arity)
     (definitial name
       (allocate 1 s.global ;; XXX: definitial が展開するコードが s.global を
                            ;; 更新する前に呼び出されるので definitial と同じ
                            ;; アドレスが使い回されることになる
         (lambda (a* ss)
           (set! s.global (expand-store (car a*) ss))
                            ;; XXX: 必要？… allocate が s.global を引数に既に
                            ;; 呼び出されている、というコードに展開されること
                            ;; になるけれども…
           (create-function
            (car a*)
            (lambda (v* s k)
              (if (= arity (length v*))
                (value v* s k)
                (wrong "Incorrect arity" 'name))))))))))

束縛自体のアドレスを陽に利用することがないので問題とならない、と考えられますけれども、見落としがあるかもしれない…疑問です。

evaluate-quote もそうだけれども、実装に使用している処理系の関数を呼び出す時（その逆も然り）、値のやり取りに注意する必要があるのも、これまでの実装と特に異なる部分です。例えば apply を実装するとすると。

(definitial list (create-function -12 allocate-list))

(definitial apply
  (create-function
   -11
   (lambda (v* s k)
     (if (>= (length v*) 2)
       (let ((fn (car v*))
             (args (cdr v*)))
         (if (eq? (fn 'type) 'function)
           ((fn 'behavior)
            (let flat ((args args))
              (if (null? (cdr args))
                (let loop ((cell (car args)))
                  (cond ((eq? cell the-empty-list) '())
                        ((eq? (cell 'type) 'pair)
                         (cons (s (cell 'car)) (loop (s (cell 'cdr)))))
                        (else (wrong "Improper list not allowed" 'apply))))
                (cons (car args) (flat (cdr args)))))
            s k)
           (wrong "Must be a function" 'apply)))
       (wrong "Incorrect arity" 'apply)))))

(is '(1 2) (evaluate1 '(list 1 2)))
(is 3 (evaluate1 '(apply + '(1 2))))
(is '(1 2 3 4 5) (evaluate1 '(apply list 1 2 3 '(4 5))))
(test* "" "error" (evaluate1 '(apply 1 2))
       (lambda (_e r)
         (string-prefix? "Must be a function" (~ r 'message))))
(test* "" "error" (evaluate1 '(apply list 1 2))
       (lambda (_e r)
         (string-prefix? "Improper list not allowed" (~ r 'message))))

...

apply へ渡される最後の引数はリストなのだけれども、そのままでは (fn 'behavior) へ直接渡すことはできないことに注目します。

一方、 lambda list にドット対を指定することができるようにすると、今度は逆に、最後の引数となる名前を、そのまま環境へ v* を値に取ることはできません。値がメモリに保持される所で allcoate-list を呼びます。

(define (arity-compatible? n* v*)
  (cond ((pair? n*)
         (and (pair? v*)
              (arity-compatible? (cdr n*) (cdr v*))))
        ((null? n*) (null? v*))
        ((symbol? n*) #t)))

(is #t (arity-compatible? '(a) '(a)))
(is #f (arity-compatible? '(a) '(a b)))
(is #f (arity-compatible? '(a) '(a b c)))
(is #t (arity-compatible? '(a . c) '(a b)))
(is #t (arity-compatible? '(a . c) '(a)))

(define (arityn n*)
  (cond ((pair? n*) (+ 1 (arityn (cdr n*))))
        ((null? n*) 0)
        (else 1)))

(is 1 (arityn '(a)))
(is 2 (arityn '(a b)))
(is 2 (arityn '(a . b)))

(define (evaluate-nlambda n* e* r s k)
  (define (update-environment r n* a*)
    (cond ((pair? n*)
           (update-environment (update r (car n*) (car a*))
                               (cdr n*)
                               (cdr a*)))
          ((null? n*) r)
          (else (update r n* (car a*) ))))
  (define (update-store s a* v* n*)
    (cond ((pair? n*)
           (update-store (update s (car a*) (car v*))
                         (cdr a*) (cdr v*) (cdr n*)))
          ((null? n*) s)
          (else (allocate-list v* s (lambda (v ss)
                                      (update ss (car a*) v))))))

  (allocate 1 s
    (lambda (a* ss)
      (k (create-function
          (car a*)
          (lambda (v* s k)
            (if (arity-compatible? n* v*)
              (allocate (arityn n*) s
                (lambda (a* ss)
                  (evaluate-begin e*
                                  (update-environment r n* a*)
                                  (update-store ss a* v* n*)
                                  k)))
              (wrong "Incorrect arity"))))
         ss))))

(set! evaluate-lambda evaluate-nlambda)

(is '(a b (c d)) (evaluate1 '((lambda (a b . c) (list a b c))
                              'a 'b 'c 'd)))
(is '((a b) (a b ())) (evaluate1 '((lambda (a b . c)
                                     (list
                                      (apply list a b c)
                                      (list a b c)))
                                   'a 'b)))