Scheme闭包、递归框架与原语[#52]

Scheme 闭包应用 apply-value 的定义[mce-apply]

Defines: (apply-value map-values all-lists? all-empty? any-empty?)

Assembled in Scheme 解释器的装配计划, Scheme求值与闭包应用模块

Outputs: metacircular.scm, lp-example/mce/engine.scm

Requires: evaluate-sequence, extend-environment

(define (apply-value procedure arguments)
       (cond
         ((and (vector? procedure) (eq? (vector-ref procedure 0) 'primitive))
          (let ((implementation (vector-ref procedure 1)))
            (cond ((eq? implementation 'map)
                   (map-values (car arguments) (cdr arguments)))
                  ((eq? implementation 'apply)
                   (unless (= (length arguments) 2) (throw 'mce-arity 'apply arguments))
                   (apply-value (car arguments) (cadr arguments)))
                  (else (apply implementation arguments)))))
         ((and (vector? procedure) (eq? (vector-ref procedure 0) 'closure))
          (evaluate-sequence (vector-ref procedure 2)
            (extend-environment (vector-ref procedure 1) arguments
                                (vector-ref procedure 3))))
         (else (throw 'mce-not-procedure procedure))))

(define (map-values procedure lists)
       (unless (and (pair? lists) (all-lists? lists)) (throw 'mce-arity 'map lists))
       (if (null? (car lists))
           (if (all-empty? lists) '() (throw 'mce-arity 'map lists))
           (begin
             (when (any-empty? lists) (throw 'mce-arity 'map lists))
             (let ((value (apply-value procedure (map car lists))))
               (cons value (map-values procedure (map cdr lists)))))))

(define (all-lists? xs)
       (or (null? xs) (and (list? (car xs)) (all-lists? (cdr xs)))))

(define (all-empty? xs)
       (or (null? xs) (and (null? (car xs)) (all-empty? (cdr xs)))))

(define (any-empty? xs)
       (and (pair? xs) (or (null? (car xs)) (any-empty? (cdr xs)))))

apply-value对原语调用宿主apply，对闭包则扩展闭包保存的环境，再进入evaluate-sequence。evaluate与apply-value相互调用，它们进入同一个装配模块，而不需要文章按依赖图排列。

Scheme 环境查找、扩展与 define 的实现[mce-env]

Defines: (extend-environment lookup define-value!)

Assembled in Scheme 解释器的装配计划, Scheme环境模块

Outputs: metacircular.scm, lp-example/mce/environment.scm

(define (extend-environment names values outer)
       (unless (= (length names) (length values)) (throw 'mce-arity names values))
       (cons (vector (map cons names values)) outer))

(define (lookup name environment)
       (if (null? environment) (throw 'mce-unbound name)
           (let ((binding (assq name (vector-ref (car environment) 0))))
             (if binding (cdr binding) (lookup name (cdr environment))))))

(define (define-value! name value environment)
       (let* ((frame (car environment)) (binding (assq name (vector-ref frame 0))))
         (if binding (set-cdr! binding value)
             (vector-set! frame 0 (cons (cons name value) (vector-ref frame 0))))))

环境是框架链，每个框架保存可变的association list。闭包捕获这条链；define把递归函数加入闭包捕获的同一个框架，所以函数体中的自引用能够找到它。对象语言环境保存用户程序的变量；宿主LP实例的binding保存解释器函数，两种作用域彼此区分。

program. Scheme 解释器的初始原语环境[mce-primitives]

Defines: (initial-environment)

Assembled in Scheme 解释器的装配计划, Scheme原语模块

Outputs: metacircular.scm, lp-example/mce/primitives.scm

Requires: extend-environment

(define (initial-environment)
       (let ((bindings (list (cons '+ +) (cons '- -) (cons '* *) (cons '= =)
                             (cons '< <) (cons 'cons cons) (cons 'car car)
                             (cons 'cdr cdr) (cons 'null? null?) (cons 'list list)
                             (cons 'cadr cadr) (cons 'caddr caddr) (cons 'cddr cddr)
                             (cons 'caar caar) (cons 'length length) (cons '>= >=)
                             (cons 'number? number?) (cons 'boolean? boolean?)
                             (cons 'string? string?) (cons 'symbol? symbol?)
                             (cons 'pair? pair?) (cons 'list? list?) (cons 'not not)
                             (cons 'eq? eq?) (cons 'equal? equal?) (cons 'memq memq)
                             (cons 'vector vector) (cons 'vector? vector?)
                             (cons 'vector-ref vector-ref) (cons 'vector-set! vector-set!)
                             (cons 'assq assq) (cons 'set-cdr! set-cdr!) (cons 'throw throw)
                             (cons 'map 'map) (cons 'apply 'apply))))
         (extend-environment (map car bindings)
           (map (lambda (binding) (vector 'primitive (cdr binding))) bindings) '())))

数值和列表原语借用宿主，eval、apply、环境与闭包机制由解释器实现。它不是完整Scheme实现。let、let*、cond、and／or和unless／when都由解释器处理，覆盖其自身源码所用的形式；初始原语表不提供宿主eval。自解释案例实际运行同一计划的定义。