lookup-variable-value

下面的 lookup-variable-value 是基于练习XX，已经抽象出一个 lookup-env 的操作。

;; a new lookup-variable-value
;; which can signal an error caused by unassigned variable
(define (lookup-variable-value var env)
  (let ((var-val (lookup-env var env)))
    (cond ((null? var-val)
           (error 'lookup-variable-value "Unbound variable" var))
          ((eq? (cdr var-val) '*unassigned*)
           (erorr 'lookup-variable-value "Assign to an unassigned variable" var))
          (else
           (cdr var-val)))))

scan-out-defines

这里的 scan-out-defines 实际需要考虑的问题更多，不仅仅是 define 语句的 sequence 的前后问题，还有 define sequence 与普通语句前后的问题。

(lambda (t)
  (inc (dec (inc t)))
  (define (inc x) (+ 1 x))
  (define (dec x) (+ -1 x)))

比如上面这个 lambda 内的定义。inc 与 dec 在定义之前就已经使用了，这是否允许呢？可以看到编程语言的设计，在实现上，实际是很小的一个部分。更多应该考虑的是如此设计是否能提供某种必要的性能。下面的实现中，将允许这样的定义。

;; scan-out-defines will desugar internal defines statements.
(define (scan-out-defines body)
  ; selectors
  (define (definition? exp)
    (tagged-list? exp definition-tag))

  (define (definition-variable exp)
    (if (symbol? (car exp))
        (car exp)
        (caar exp)))
  (define (definition-value exp)
    (if (symbol? (car exp))
        (cadr exp)
        (make-lambda (cdar exp)   ; formal parameters
                     (cdr exp)))) ; body

  (define (make-lambda parameter body)
    ((get 'constructor lambda-tag) parameter body))

  (define (make-let vars vals body)
    ((get 'constructor 'let) vars vals body))

  (define (make-assignments vars vals)
    (map (lambda (var val)
           (list assignment-tag var val))
         vars vals))

  ;; all the definition is raised to the top
  (define (collect-vars exps)
    (let* ((defs (filter definition? exps))
           (rest (filter (lambda (e)
                           (not (definition? e))) exps))
           (vars (map (lambda (e)
                        (definition-variable (cdr e))) defs))
           (vals (map (lambda (e)
                        (definition-value (cdr e))) defs)))
      (if (null? defs)
          exps
          (list
           (make-let vars
                     (map (lambda (x) ''*unassigned*) vars)
                     (append (make-assignments vars vals) rest))))))

  (collect-vars body))

collect-vars 是最主要的过程。它会首先过滤出 define 的语句，同时按照原顺序得到不是 define 的语句。最后组成一个 let 语句。值得注意的有几点：

1. scan-out-defines 应该最后返回一个 list，因为 procedure 的 body 是使用一个 list 表示的。
2. let 的实现中，let 的 body 部分应该允许传递一个 list，因为 let 的 body 部分即 lambda 的 body，而 lambda 的 body 是可以使用多语句的。
3. 语句中没有出现 define 的情况需要考虑进去。
4. 在转换的时候， '*unassigned* 应该表示为 ''*unassigned*。

安装 scan-out-defines

这里我们需要安装 scan-out-defines。与之前我们设计的有理数一样，如果有理数需要分子分母进行约分，那么除以 gcd 的部分应该放到构造函数中，以免除以 gcd 的部分被重复运行。这里也是，我们直接把 scan-out-defines 过程放到构造函数中，这样我们就可以只运行一遍就得到想要的结果了。

;; install scan-out-defines in the system
(define (make-procedure parameters body env)
  (list 'procedure parameters (scan-out-defines body) env))

测试

(assertequal? (scan-out-defines (cddr '(lambda (x)
                                         (define u 1)
                                         (define v 2)
                                         3)))
              '((let ((u '*unassigned*)
                      (v '*unassigned*))
                  (set! u 1)
                  (set! v 2)
                  3)))

(assertequal? (scan-out-defines (cddr '(lambda (t)
                                         (define (inc x) (+ 1 x))
                                         (define (dec x) (+ -1 x))
                                         (inc (dec (inc t))))))
              '((let ((inc '*unassigned*)
                      (dec '*unassigned*))
                  (set! inc (lambda (x) (+ 1 x)))
                  (set! dec (lambda (x) (+ -1 x)))
                  (inc (dec (inc t))))))

(assertequal? (scan-out-defines (cddr '(lambda (t)
                                         (inc (dec (inc t)))
                                         (define (inc x) (+ 1 x))
                                         (define (dec x) (+ -1 x)))))
              '((let ((inc '*unassigned*)
                      (dec '*unassigned*))
                  (set! inc (lambda (x) (+ 1 x)))
                  (set! dec (lambda (x) (+ -1 x)))
                  (inc (dec (inc t))))))

(assertequal? (scan-out-defines (cddr '(lambda (t)
                                         (+ t 1)
                                         (+ t -1))))
              '((+ t 1)
                (+ t -1)))

;; test evaluation

(let ((test-env (setup-environment)))
  (assert= (eval '((lambda (x)
                           (define u 1)
                           (define v 2)
                           (+ u v x)) 1) test-env)
                4)

  (assert= (eval '((lambda (t)
                          (define (inc x) (+ 1 x))
                          (define (dec x) (+ -1 x))
                          (inc (dec (inc t))))
                        10) test-env)
                11)

  (assert= (eval '((lambda (t)
                          (inc (dec (inc t)))
                          (define (inc x) (+ 1 x))
                          (define (dec x) (+ -1 x)))
                        10) test-env)
                11)

  (assert= (eval '((lambda (t)
                          (+ t 1)
                          (+ t -1))
                        10) test-env)
                9))