基于环境模型的解释器
光剑系列的第五作！前四篇：
第一篇：Let's build our mathematics by using lambda calculus && church encoding!
第二篇：惰性求值、无穷流与发生的魔法
第三篇：协程、生成器与 call/cc 的控制流
第四篇：动态作用域、词法作用域与表达式求值的环境模型
前言
又见面了！上一篇文章中我将动态作用域的实现留作了习题，一定非常恶心吧！毕竟我尝试了两天枚举了各种不用宏和用宏的解决方案都没有任何成果，只能看着看不懂的编译错误或者不期望的展开结果发呆。
如果有哪位读者做出了那个习题，请务必通过本文评论区联系我。
不过，其实只要自己实现一个解释器，就能够轻松而优雅地完成这个习题。
恰好，上一篇文章中介绍了环境模型，这将是我们解释器的原理。
我们将选择 scheme 实现解释器。因为 scheme 的解释器特别好写而作者太菜了只会这个。
实现
在实现一个具有比较多特性的 scheme 子集之前，我们将先实现一个更简单的 lambda 演算解释器。
看过第一作的读者们想必还记得 lambda 演算吧？它只含有函数一种对象，函数抽象和函数应用两种操作，已经是图灵完备的。
那么我们来实现它，使用环境模型和闭包。
预备工作 · 函数
lambda 只有函数一种核心对象。实现函数自然成为了我们的重要任务。
在环境模型下，想要实现词法作用域肯定要用闭包。所以我们的函数也将被表示为一个闭包。
它含有四个字段：第一个是符号 closure，用于标识身份。后面三个字段分别是形式参数、函数体和保存的环境。这些是闭包的核心要素。
我们可以先实现单参数的函数。因为具有一等公民函数的特性，我们可以通过柯里化实现多参数函数。
对于闭包的存储，随便用什么都行。我用的是一个 vector（定长数组）。
(define (make-closure params body env)
(vector 'closure params body env))有了函数的数据结构标识，我们还需要有对于闭包的操作：
(define (closure? obj)
(and (vector? obj) (eq? (vector-ref obj 0) 'closure)))
(define (closure-param closure) (vector-ref closure 1))
(define (closure-body closure) (vector-ref closure 2))
(define (closure-env closure) (vector-ref closure 3))然后，为了支持对于函数的应用和抽象，我们需要一些关于环境的操作。
预备工作 · 环境
第一步是定义一个全局环境。
(define global-env (list '()))注意，环境会构成一个链，所以我们用一个链表表示。而链表内每个元素是一个映射。这里选择了简单的关联列表实现映射，虽然它的查找复杂度是线性的，但是可以简化实现。对于我们的教学示例，复杂度/性能并不是最重要的因素。
同样的，有了环境的对象，我们就有对它的操作：
; 接受一个参数名，一个参数值(会是个闭包)，和父环境
(define (extend-environment param arg base-env)
(let ((frame (list (cons param arg)))) ; 创建只有一个绑定的新帧
(cons frame base-env)))
(define (lookup-variable-value var env)
(let loop ((e env))
(if (null? e)
(error "Unbound variable" var)
(let ((frame (car e)))
(cond
((assoc var frame) => cdr) ; R6RS 的 => 很有用
(else (loop (cdr e))))))))
(define (define-variable! var val)
; define 总是修改最外层（全局）环境
(set-car! global-env
(cons (cons var val) (car global-env))))预备工作到这里就结束了。下面是重头戏。
求值器 · 主循环
我们需要一个函数来对传入的表达式求值。
那么，求值器应该处理哪些情况呢？
首先，肯定有 define 和 lambda 两种特殊形式。
对于 define，很简单：只需要求值被绑定值然后绑定到变量名上就可以了：
((eq? op 'define)
(let* ((var (cadr exp))
(val-exp (caddr exp))
(value (calc val-exp env)))
(define-variable! var value)
'ok)) ; 提示信息而对于 lambda，我们采取一种非常懒惰的策略：拆开 S 表达式，然后再包装成一个闭包，函数体丝毫不动：
((eq? op 'lambda)
(let ((param (caadr exp))
(body (caddr exp)))
(make-closure param body env)))之后呢？之后还要处理递归的边界情况：单个符号。
((symbol? exp) (lookup-variable-value exp env))然后，三种简单情况就都做完了。下面是整个过程中最困难、重要和精妙的步骤：函数应用。
对于这种情况，我们按照一贯做法先求值操作符，然后从左到右求值各操作数。
最后怎么办呢？不急。我们进行一个锅的甩，使用一个另外的 apply-proc 函数来完成这项工作 ;)
(else
(let ((proc (calc (car exp) env)) ; 求值函数部分 -> 必须是个闭包
(arg (calc (cadr exp) env))) ; 求值参数部分 -> 也是个值(闭包)
(apply-proc proc arg)
)
)最后加上错误处理，就得到了求值器 calc 的完整代码：
(define (calc exp env)
(cond
((symbol? exp) (lookup-variable-value exp env))
((list? exp)
(let ((op (car exp)))
(cond
((eq? op 'lambda)
(let ((param (caadr exp))
(body (caddr exp)))
(make-closure param body env)
)
)
((eq? op 'define)
(let* ((var (cadr exp))
(val-exp (caddr exp))
(value (calc val-exp env)))
(define-variable! var value)
'ok))
(else
(let ((proc (calc (car exp) env)) ; 求值函数部分 -> 必须是个闭包
(arg (calc (cadr exp) env))) ; 求值参数部分 -> 也是个值(闭包)
(apply-proc proc arg)
)
)
)
)
)
(else (error "Invalid expression" exp))
)
)各位可能很好奇 apply-proc 是何方神圣。不急不急，我这就把它放出来：
(define (apply-proc proc arg)
(if (closure? proc)
(let ((param (closure-param proc))
(body (closure-body proc))
(env (closure-env proc)))
; 关键步骤：在闭包 *捕获的环境* 上扩展新绑定
(let ((new-env (extend-environment param arg env)))
(calc body new-env)))
(error "Not a procedure" proc)))惊不惊喜，意不意外？
完成了一切实际计算工作的 apply-proc，其实什么也没干！
它只不过是把闭包保存的参数名和实际参数制造了一个绑定，添加到环境中。然后又把锅甩了回去，递归调用 calc 对函数体进行求值！
不过不要忙着大跌眼镜。apply-proc 干的这件事，其实和“代入”非常类似。这样它能够生效就一点都不奇怪了。
只不过环境模型下不是直接代入，而是扩展环境加入新的绑定。
一点边角工作
交互循环以及美观打印器。由于不是重点，让 AI 生成的。
(define (run exp)
(calc exp global-env))
(define (pretty-print obj)
(cond
; 我们的主角：闭包
((closure? obj)
(display "#<closure: (lambda (")
(write (closure-param obj))
(display ") ")
(pretty-print (closure-body obj)) ; 递归地美化打印函数体
(display ")>"))
; 对列表/S表达式进行美化
((pair? obj)
(display "(")
(pretty-print (car obj))
(let loop ((rest (cdr obj)))
(cond
((null? rest) (display ")"))
((pair? rest)
(display " ")
(pretty-print (car rest))
(loop (cdr rest)))
; 处理点对列表，如 (a . b)
(else
(display " . ")
(pretty-print rest)
(display ")")))))
; 其他所有类型（符号、布尔值等）用默认方式打印
(else (write obj))))
(define (repl)
(display "Lambda> ")
(let ((exp (read)))
(if (eq? exp 'exit)
(display "Goodbye!")
(begin
(let ((result (run exp))) ; <-- 使用 run 而不是 calc
(pretty-print result)
(newline))
(repl)))))如何实现动态作用域？
太简单了。求值函数应用的时候，不要把它放在保存的环境中求值，而是直接在当前环境中求值。
具体的，对于 apply-proc 函数：
(define (apply-proc proc arg) ; 在这里加入 env 参数，让 calc 传入求值时的当前环境
(if (closure? proc)
(let ((param (closure-param proc))
(body (closure-body proc))
(env (closure-env proc))) ; 去掉这一项，直接使用 calc 传入的当前环境而不是函数内部保存的环境
(let ((new-env (extend-environment param arg env)))
(calc body new-env)))
(error "Not a procedure" proc)))这样函数的存储中也就不需要保存定义时环境了。
后续
我们的解释器还很幼稚，只能处理函数一种对象。一切数字、布尔等等都需要邱奇编码来模拟，可读性差且效率低下。
所以，我们就有了一个超级加强版的解释器！
; (make-closure '(p1 p2) '(body) env)
(define (make-closure params body env)
(vector 'closure params body env))
(define (make-closure-with-name params body env name)
(vector 'closure params body env name))
(define (closure? obj)
(and (vector? obj) (eq? (vector-ref obj 0) 'closure)))
(define (closure-param closure) (vector-ref closure 1))
(define (closure-body closure) (vector-ref closure 2))
(define (closure-env closure) (vector-ref closure 3))
(define (closure-name closure) (vector-ref closure 4))
(define global-env (list '()))
(define intrinsics (list (cons '+ +) (cons '- -) (cons '* *) (cons '/ /) (cons '= =) (cons '< <) (cons '> >) (cons '>= >=) (cons '<= <=) (cons 'not not) (cons 'cons cons) (cons 'car car) (cons 'cdr cdr) (cons 'map map) (cons 'filter filter)
(cons 'for-each for-each) (cons 'vector-ref vector-ref) (cons 'vector-set! vector-set!) (cons 'vector vector) (cons 'list list))) ; 内建函数。用于支持对于数字的操作等等。可以自行添加。
(define (new-environment bounds base-env)
(cons bounds base-env))
(define (lookup-variable-value var env)
(let loop ((e env))
(if (null? e)
(error var "Unbound variable")
(let ((frame (car e)))
(cond
((assq var frame) => cdr) ; R6RS 的 => 很有用
(else (loop (cdr e))))))))
(define (modify var val env)
(let loop ((e env))
(if (null? e)
(error var "Unbound variable")
(let ((frame (car e)))
(cond
((assq var frame) => (lambda (v) (set-cdr! v val)))
(else (loop (cdr e))))))))
(define (define-variable! var val)
; 合法性检查：变量名必须是符号
(when (not (symbol? var))
(error var "Variable name must be a symbol"))
; define 总是修改最外层（全局）环境
(set-car! global-env
(cons (cons var val) (car global-env))))
(define (calc exp env)
(cond
((or (number? exp) (string? exp) (vector? exp) (boolean? exp)) exp) ; 在这个解释器中，数字等原始数据结构也可以视为一种 intrinsics.
((and (list? exp) (assq (car exp) intrinsics)) =>
(lambda (x)
(let ([f (cdr x)])
(apply f
(map
(lambda (v) (calc v env))
(cdr exp)))))) ; 注意，操作数数量不匹配会由 scheme 自己报错。所以为了省事略去了。
((symbol? exp) (lookup-variable-value exp env))
((list? exp)
(let ((op (car exp)))
(cond
((eq? op 'lambda)
(let ((param (cadr exp))
(body (cons 'begin (cddr exp))))
(make-closure param body env)))
((eq? op 'define)
(let* ((var (cadr exp))
(val-exp (caddr exp))
(value (calc val-exp env)))
(if (closure? value)
(let ([param (closure-param value)]
[body (closure-body value)]
[env (closure-env value)])
(define-variable! var (make-closure-with-name param body env var)))
(define-variable! var value))))
((eq? op 'let)
(calc (cons 'begin (cddr exp))
(new-environment
(map
(lambda (x) (cons (car x) (calc (cadr x) env)))
(cadr exp))
env)))
((eq? op 'set!)
(if (not (symbol? (cadr exp)))
(error exp "Invalid syntax set!")
(modify (cadr exp) (calc (caddr exp) env) env)))
((eq? op 'begin)
(let loop ([x (cdr exp)])
(cond
((null? x) (error exp "Invalid syntax begin"))
((null? (cdr x)) (calc (car x) env))
(else (calc (car x) env) (loop (cdr x))))))
((eq? op 'quote)
(if (or (null? (cdr exp)) (not (null? (cddr exp))))
(error exp "Invalid syntax quote")
(cadr exp)))
((eq? op 'if)
(cond
((or (null? (cdr exp)) (null? (cddr exp))) (error exp "Invalid syntax if"))
((null? (cdddr exp)) (if (calc (cadr exp) env) (calc (caddr exp) env)))
((null? (cddddr exp))
(if (calc (cadr exp) env)
(calc (caddr exp) env)
(calc (cadddr exp) env)))
(else (error exp "Invalid syntax if"))))
(else
(let ((proc (calc (car exp) env)) ; 求值函数部分 -> 必须是个闭包
(arg (map (lambda (x) (calc x env)) (cdr exp)))) ; 求值参数部分 -> 也是个值(闭包)
(apply-proc proc arg))))))
(else (error exp "Invalid expression"))))
(define (apply-proc proc arg)
(if (closure? proc)
(let ((param (closure-param proc))
(body (closure-body proc))
(env (closure-env proc)))
; 关键步骤：在闭包 *捕获的环境* 上扩展新绑定
(let ((new-env
(new-environment
(map cons param arg)
env)))
(calc body new-env)))
(error proc "Not a procedure")))
(define (run exp)
(calc exp global-env))
(define (pretty-print obj)
(cond
; 我们的主角：闭包
((closure? obj)
(if (= (vector-length obj) 4) (display "#<procedure>") (begin (display "#<procedure ") (display (closure-name obj)) (display ">"))))
; 其他所有类型（符号、布尔值等）用默认方式打印
(else (display obj))))
(define (repl)
(display "Lambda> ")
(let ((exp (read)))
(if (eq? exp 'exit)
(display "Goodbye!")
(begin
(let ((result (run exp))) ; <-- 使用 run 而不是 calc
(pretty-print result)
(newline))
(repl)))))它实现的是一个 scheme 的核心子集。
相较于上面的 lambda 解释器，它主要增加了以下特性：
- 多参数函数调用\ 这个是通过对 apply-proc 的修改做到的（虽然 calc 和扩展环境的函数也都进行了修改）。我们将所有参数存储为列表，apply-proc 时将形式参数和实际参数的列表通过 map 变成一个新的环境帧，然后链接到老环境上。
- 数字、字符串、向量、布尔值的原生支持\
实现非常简单，只用了
((or (number? exp) (string? exp) (vector? exp) (boolean? exp)) exp)一行，大概就是让这些量摆脱常规的变量查找求值，直接返回自己。 - 来自 scheme 的内建函数\ 这一项是通过 intrinsics 列表做到的。我们先在 intrinsics 列表中查找对应的内建函数，如果有匹配就直接应用。这样我们就可以处理数字等等了。你也可以自行向 intrinsics 列表中添加新的内建函数。
- 对于 quote、let、begin、set!、if 等特殊形式的支持\ 注意，标准 scheme 的 define 可以在内部块作用域的开头出现，定义作用域在块内的变量。而我为了简化没有实现这一点。
- 函数的美观打印：不再显示函数体和参数列表，而是显示函数名，就像标准 scheme 实现那样：
#<procedure>/#<procedure name>。这样就可以方便的用它来玩邱奇编码了！
一些意想不到的特性
我们的解释器是支持递归的。
因为定义递归函数时，calc 会直接拆解表达式并构建闭包，最后绑定到函数名上，完全不动函数体。所以就不会出现递归函数名被视为未定义变量的状况。而调用时，函数名已经存在于环境中，对于递归函数的调用会正确地指向它自己。
我们的解释器支持尾调用优化。
我们自己没有出手实现这个特性。但是通过对 calc 和 apply-proc 的观察，你可以发现它们在处理函数应用时互相的递归是尾递归的，所以恰好借用了宿主语言 scheme 的尾递归优化。
并且，尾调用被优化掉之后，无用的环境帧也就被 GC 清除了。所以，我们的解释器巧妙地利用了宿主语言的特性，获得了 TCO（尾调用优化）。
后记
总之就是这样了。我们实现了一个简单的 lambda 演算的解释器，并展示了如何将它扩展到更强大的 scheme 方言。过程中顺便解决了上篇文章那个极其恶心的习题。
下次再会！