問題4.16

sicp

内部定義での束縛のあり方について。的な話。
問題4.19の例ですが、これを現在の超循環評価器で実行すると

;;; M-Eval input:
(let ((a 1))
  (define (f x)
    (define b (+ a x))
    (define a 5)
    (+ a b))
  (f 10))
;;; M-Eval value:
16

という結果がでます。これは、内部手続きにおいて、そのdefineの有効範囲が内部手続き全体に及ぶべきという見方に反する結果です。
もしbとaが同時に定義されるとみなすのなら、(f 10)の値は20になるべき。
あるいは、その実装が困難ならば、(define b (+ a x))においてaが未定義であるとするエラーを吐き出すべきです。
この考えに基づいて、超循環評価器を変更します。

4.16

a.

先日再定義したlookup-variable-valueを次のように変更すればいいです。

(define (lookup-variable-value var env)
  (define (env-loop env)
    (scan-frame env
                var
                (lambda (x) (env-loop (enclosing-environment x)))
                (lambda (x) (if (eq? (car x) '*unassigned*)
                                (error "unbound -- LOOKUP-VARIABLE-VALUE :" var)
                                (car x)))))
  (env-loop env))

ただ、次のような場合、

;;; M-Eval input:
(define x '*unassigned*)
;;; M-Eval value:
ok

;;; M-Eval input:
x
unbound -- LOOKUP-VARIABLE-VALUE : x

エラーが出てきます。まあ仕様上仕方ないのですが、実際に使うなら'*unassigned*を評価器内部で特別扱いしないとだめです。(ユーザーからの'*unassigned*は内部で別の表現に変換するとか)

b.

簡単そうだったのに結構時間かかりました。

(define (scan-out-defines body)
  (define (make-variable-clauses body)
    (if (definition? (car body))
        (cons (list (definition-variable (car body))
                    ''*unassigned*)
              (make-variable-clauses (cdr body)))
        '()))
  (define (definition->assignment-body body)
    (if (definition? (car body))
        (cons (make-assignment (definition-variable (car body))
                               (definition-value (car body)))
              (definition->assignment-body (cdr body)))
        body))
  (if (definition? (car body))
      (list (apply-in-underlying-scheme
             make-let
             (cons (make-variable-clauses body)
                   (definition->assignment-body body))))
      body))

とりあえず、気をつける点は*unassigned*は超循環評価器の中でquoteされた記号でなければならないので、ここでquoteを二個つける必要があります。一個だけだと*unassigned*という識別子として超循環評価器が捉えてしまい、定義されてない記号としてエラーが出てしまいます。
あと、bodyは式のリストになってますが、make-letは(let ((v1 l1) ... (vn ln)) )のような単一の式を返す仕様にしてあったので、返す時にリストにしなければなりません。
また、bodyの最初の式がdefinition?であるかどうかを判定しないと、letとlambdaの間を行ったり来たりして無限ループに陥ります。
definition->assignment-bodyで代入の構成子make-assignmentを使ってますが、これは

(define (make-assignment var val)
  (list 'set! var val))

って感じです。正しく変換してくれるか確かめます。

> (scan-out-defines
   '((define u 3)
     (define v 5)
     (+ u v)))
((let ((u '*unassigned*) (v '*unassigned*)) (set! u 3) (set! v 5) (+ u v)))

大丈夫なようです。
蛇足ですが、scan-out-definesはmake-variable-clausesとdefinition->assignment-bodyが似た構造なので、accumulate(のようなもの)を使って次のようにかけます。

(define (scan-out-defines body)
  (define (accumulate op end? init term seq)
    (if (end? seq)
        init
        (op (term seq) (accumulate op end? init term (cdr seq)))))
  (define (not-def? x) (not (definition? x)))
  (define (make-variable-clauses body)
    (accumulate cons
                (lambda (x) (not-def? (car x)))
                '()
                (lambda (x) (list (definition-variable (car x)) ''*unassigned*))
                body))
  (define (definition->assignment-body body)
    (append
     (accumulate cons
                 (lambda (x) (not-def? (car x)))
                 '()
                 (lambda (x) (make-assignment (definition-variable (car x))
                                              (definition-value (car x))))
                 body)
     (filter not-def? body)))
  (let ((args (cons (make-variable-clauses body) (definition->assignment-body body))))
    (if (definition? (car body))
        (list (apply-in-underlying-scheme make-let args))
        body)))

さっきの方が無駄はないです(definition->assignment-bodyでappendしてるため)。
もっと限定的に抽象して、

(define (scan-out-defines body)
  (define (get-def-items term body)
    (if (not (definition? (car body)))
        '()
        (cons (term (car body)) (get-def-items term (cdr body)))))
  (define (make-variable-clauses body)
    (get-def-items (lambda (x) (list (definition-variable x) ''*unassigned*)) body))
  (define (definition->assignment-body body)
    (append (get-def-items (lambda (x) (make-assignment (definition-variable x)
                                                        (definition-value x)))
                           body)
            (filter (lambda (x) (not (definition? x))) body)))
  (if (definition? (car body))
      (let ((args (cons (make-variable-clauses body) (definition->assignment-body body))))
        (list (apply-in-underlying-scheme make-let args)))
      body))

こんな風に書くとほんの少し短くなった(ような気がする)。いや、一番最初のが一番すっきりしてますね。たぶん。やっぱりあれにしよう。
マクロを使って書いてもみようと思ったんですが、いまいちうまくかけません。というかdefine-syntaxとsyntax-rulesの正確な挙動も実はよく分かってません。ググっても細かいところまで解説してるところが見つからないです。ということで今回は諦めます。

c.

make-procedureに組み込んだほうがいいです。make-procedureは構成子なので高々一回しか呼び出されませんが、procedure-bodyは選択子なので何回か呼び出される可能性があるからです。
こんな感じに組み込みます。

(define (make-procedure parameters body env)
  (list 'procedure parameters (scan-out-defines body) env))

超循環評価器を走らせてみます。

;;; M-Eval input:
(let ((a 1))
  (define (f x)
    (define b (+ a x))
    (define a 5)
    (+ a b))
  (f 10))
unbound -- LOOKUP-VARIABLE-VALUE : a

冒頭述べた正しくない結果ではなく、エラーを出すことができました。
evalをちょっと変えて(呼び出される度にexpを表示するようにして)、内部定義があった場合の式の変化の様子を観察してみます。

;;; M-Eval input:
((lambda ()
   (define u 3)
   (define v 5)
   (+ u v)))

((lambda () (define u 3) (define v 5) (+ u v)))
(lambda () (define u 3) (define v 5) (+ u v))
(let ((u '*unassigned*) (v '*unassigned*)) (set! u 3) (set! v 5) (+ u v))
((lambda (u v) (set! u 3) (set! v 5) (+ u v)) '*unassigned* '*unassigned*)
(lambda (u v) (set! u 3) (set! v 5) (+ u v))
'*unassigned*
'*unassigned*
(set! u 3)
3
(set! v 5)
5
(+ u v)
+
u
v
;;; M-Eval value:
8

正しく変換しているようです。


ていうか4章の問題重たいです。明日テストあるので今日はこれだけ。