禅意风格编程(zen-style programming)

1. 第一部分符号式编程
2. 第二部分算法
3. 第三部分 zenlisp 实现
- 3.1. 12. c 部分
- 3.2. 13. lisp 部分
4. 附录 A

1. 第一部分符号式编程

本部分通过一种纯符号化、词法作用域、函数式的 LISP 变体 zenlisp 来讨论符号式编程的基础.

Zenlisp 类似于 Scheme, 但更简单.

作为纯符号化语言, 它只有两种基本数据类型: 符号和有序对.

Zenlisp 实现了函数式编程的范式. 函数式编程专注于表达式的求值. 程序是一系列将值映射到值的函数集合. 尾递归表达式在常数空间内求值, 使得迭代成为递归的一个特例.

Zenlisp 程序通常没有副作用.

尽管本文中描述的技术是以一种 LISPy 语言呈现的, 但纯符号化的方法使得将这些技术轻松地应用于其他函数式语言, 甚至可能应用于其他范式的语言.

1.1. 1. 基本方面

1.1.1. 1.1 符号和变量

这是一个引用的符号:

'marmelade

它被称为引用的符号, 因为它前面有一个引号字符.

任何被引用的东西都会归约到其自身:

'marmelade => 'marmelade

=> 操作符读作“归约到”或“求值为”.

=> 的左边是一个程序, 右边被称为该程序的范式 (或“结果”).

未被引用的符号称为变量.

这是一个变量:

food

变量的范式是与该变量关联的值:

(define food 'marmelade)
food => 'marmelade

上面的 define 将值 'marmelade 绑定到变量 food.

将变量绑定到一个值之后, 每次引用该变量都会得到绑定到该变量的值; 变量归约到它的值:

food => 'marmelade

符号和变量是相互独立的:

(define marmelade 'fine-cut-orange)
marmelade => 'fine-cut-orange

尽管 marmelade 现在指向 'fine-cut-orange, 但引用的符号 'marmelade 仍然归约到其自身, 而 food 仍然归约到 'marmelade:

'marmelade => 'marmelade
food => 'marmelade

一旦定义, 变量的值通常不会改变.

没有关联值的符号不是一个有效的变量:

undefined-symbol => bottom

Bottom 表示一个未定义的值.

任何归约到 bottom 的都应被视为错误.

一个引用的符号是它自己的值, 所以没有关联的引用符号是可以的:

'undefined-symbol => 'undefined-symbol

1.1.2. 1.2 函数

下面的表达式将 append 函数应用于两个参数:

(append '(pizza with) '(extra cheese))
=> '(pizza with extra cheese)

数据 '(pizza with) 和 '(extra cheese) 是列表. Append 将它们连接起来.

列表是它们的范式, 因为它们被引用了:

'(pizza with cheese) => '(pizza with cheese)

函数应用的范式是被应用函数返回的值:

(reverse '(pizza with pepperonies))
=> '(pepperonies with pizza)

列表和函数应用共享相同的表示法; 它们仅通过附加在列表上的引号字符来区分:

(reverse '(ice water)) => '(water ice)
'(reverse '(ice water)) => '(reverse '(ice water))

在函数应用上附加引号字符会将其变成列表, 但是…

从列表中移除引号并不一定会将其变成函数应用:

(pizza with pepperonies) => bottom

这行不通, 因为之前没有定义名为 “pizza” 的函数.

不过, 你可以定义一个:

(define (pizza topping)
  (list 'pizza 'with topping))

定义了一个名为 pizza 的函数, 它接受一个名为 topping 的参数.

函数体是 list 对三个参数的应用: 符号 'pizza 和 'with, 以及变量 topping. 函数体有时也称为该函数的项 (term).

当 pizza 被应用时, list 会形成一个包含给定参数的新列表:

(pizza 'anchovies) => '(pizza with anchovies)

顺便说一句, 符号 'pizza 和 'with 的引号并没有消失.

列表前的引号字符会引用该列表中包含的所有内容:

'(gimme a (pizza 'hot-chili))
=> '(gimme a (pizza 'hot-chili))

如果你想归约列表的成员, 你必须使用 list 函数:

(list 'gimme 'a (pizza 'hot-chili))
=> '(gimme a (pizza with hot-chili))

1.2.1 调用函数
Pizza-2 像 pizza, 但接受两个参数:
```
(define (pizza-2 top1 top2)
  (list 'pizza 'with top1 'and top2))
```
变量 top1 和 top2 是函数的变量. 它们有时也称为函数的形式参数.

函数应用的值被称为实际参数或简称为参数. 函数的变量列表称为其参数列表.

在下面的例子中, '(extra cheese) 和 '(hot chili) 是 (实际) 参数:
```
(pizza-2 '(extra cheese) '(hot chili))
=> '(pizza with (extra cheese) and (hot chili))
```
以下是上述函数应用期间发生的事情:
1. 保存 top1 和 top2 的值;
2. '(extra cheese) 被绑定到 top1;
3. '(hot chili) 被绑定到 top2;
4. (list 'pizza 'with top1 'and top2) 被归约, 得到结果 R;
5. top1 和 top2 被绑定回第 1 步中保存的值;
6. 返回 R.
由于第 1 步和第 5 步, 函数的变量是该函数的局部变量.

因此, 多个函数可以共享相同的变量名. 这些函数中的每一个都有自己的局部 x:
```
(define (f x) (append x x))
(define (g x) (reverse x))
```
函数的参数是按位置匹配的:
```
(pizza-2 'olives 'pepper) => '(pizza with olives and pepper)
(pizza-2 'pepper 'olives) => '(pizza with pepper and olives)
```
1.2.2 函数复合
这是函数 reverse 和 append 的复合:
```
(reverse (append '(ice with) '(juice orange)))
=> '(orange juice with ice)
```
函数复合用于从已有的函数构造新函数:
```
(define (palindrome x)
  (append x (reverse x)))
```
在 palindrome 中, append 的第二个参数是 reverse 返回的值.

Zenlisp 使用应用序求值.

因此, (reverse x) 首先被归约到其范式, 然后该范式作为参数传递给 append.

传递给同一函数的多个参数不会按任何特定顺序进行归约, 但在示例中假定为从左到右求值.

下面是 palindrome 的一个应用示例:
```
(palindrome '#12345)
```
数据 '#12345 只是 zenlisp 中 '(1 2 3 4 5) 的简写 — 任何由单个字符符号组成的列表都可以用这种方式缩写.

该应用按如下方式归约 (-> 操作符表示部分归约):
```
(palindrome '#12345)
-> (append x (reverse x))            ; reduced palindrome
-> (append '#12345 (reverse x))      ; reduced first x
-> (append '#12345 (reverse '#12345)) ; reduced second x
-> (append '#12345 '#54321)          ; reduced application of reverse
=> '#1234554321                      ; reduced application of append
```
在部分归约中, 函数应用的一个或多个子表达式 (如变量或内嵌的应用) 被归约到它们的范式.

1.1.3. 1.3 条件

符号 :f 表示逻辑假:

:f => :f

:F 归约到其自身, 所以不必引用它.

符号 :t 和 t 表示逻辑真:

:t => :t
t => :t

:T 和 t 都归约到 :t, 所以它们也不必引用.

如果你想知道为什么有两个值表示真, 那是因为在某些上下文中, t 看起来比 :t 更好.

cond 伪函数实现条件归约:

(cond (:f 'bread)
      (:t 'butter))
=> 'butter

cond 的每个参数都称为一个子句 (clause).

每个子句都由一个谓词 (predicate) 和一个主体 (body) 组成:

(predicate body)

Cond 的工作方式如下:

它将其第一个子句的谓词归约为其范式;
如果谓词归约为真, cond 的值就是与该谓词相关联的主体的范式;
如果谓词归约为假, cond 继续处理下一个子句.

Cond 在找到一个真谓词后立即返回:

(cond (:f 'bread)
      (:t 'butter)
      (:t 'marmelade))
=> 'butter

因此, 上面的 cond 永远不会返回 'marmelade.

cond 的子句用尽是一个错误:

(cond (:f 'false)
      (:f 'also-false))
=> bottom

因此, cond 的最后一个子句应始终以常量真作为其谓词, 以便它可以捕获所有剩余情况.

这是一个使用 cond 的函数:

(define (true value)
  (cond (value (list value 'is 'true))
        (t (list value 'is 'false))))

True 判断一个值是否为“真”.

让我们尝试一些值:

(true :f) => '(:f is false)

正如预期的那样.

(true :t) => '(:t is true)

也很好. 以下是其他一些表达式的真值: ¹

(true 'orange-fine-cut) => '(orange-fine-cut is true)
(true '0) => '(0 is true)
(true true) => '({closure (value)} is true)
(true ()) => '(() is true)

看起来大多数扔给 true 的值结果都为真.

确实:

Cond 将除 :f 之外的所有值都解释为真. 只有 :f 是假.

1.1.4. 1.4 递归

这里有一些有趣的函数:

Car 提取列表的第一个成员:

(car '(first second third)) => 'first
(car '#abcdef) => 'a

cdr 函数提取列表的尾部:

(cdr '(first second third)) => '(second third)
(cdr '#abcdef) => '#bcdef

单成员列表的尾部是 ():

(cdr '(first)) => ()

() 读作 “nil”; 它表示空列表.

null 谓词测试其参数是否为 ():

(null '#abcde) => :f
(null ()) => :t

当一个函数总是返回 :t 或 :f 时, 它被称为谓词.

eq 谓词测试两个符号是否相同:

(eq 'orange 'orange) => :t
(eq 'orange 'apple) => :f

Memq 使用了以上所有函数:

(define (memq x a)
  (cond ((null a) :f)
        ((eq x (car a)) a)
        (t (memq x (cdr a)))))

它在符号列表 a 中定位 x 的第一次出现:

(memq 'c '#abcde) => '#cde

当 a 不包含 x 时, memq 返回 :f:

(memq 'x '#abcde) => :f

当传递给 memq 的列表为空时, memq 的 cond 的第一个子句适用, memq 返回 :f:

(memq 'x ()) => :f

第二个子句使用 eq 来判断 x 和 (car a) 是否表示同一个符号. 如果是, memq 返回 a:

(memq 'x '#x) => '#x

最后一个子句将 memq 应用于列表 a 的尾部:

(memq x (cdr a))

因为 memq 为了计算自己的结果而应用了 memq, 所以据说它会递归; memq 被称为递归函数.

memq 的一次应用归约如下:

(memq 'c '#abcde)
-> (cond ((null '#abcde) :f)
         ((eq 'c (car '#abcde)) '#abcde)
         (t (memq 'c (cdr '#abcde))))
-> (cond ((eq 'c (car '#abcde)) '#abcde)
         (t (memq 'c (cdr '#abcde))))
-> (cond (t (memq 'c (cdr '#abcde))))
-> (memq 'c (cdr '#abcde))
-> (memq 'c '#bcde)
-> (memq 'c '#cde)
=> '#cde

cond 的每个子句覆盖一种情况.

递归函数的非递归情况称为其平凡情况 (trivial cases), 递归情况称为其一般情况 (general cases).

递归用于表达迭代.

1.1.5. 1.5 形式和表达式

Car 和 cdr 提取列表的头部 (第一个成员) 和尾部 (除第一个成员外的所有成员):

(car '(large banana split)) => 'large
(cdr '(large banana split)) => '(banana split)

cons 函数通过将一个新头部附加到一个现有列表来创建一个新列表:

(cons 'banana ()) => '(banana)
(cons 'banana '(split)) => '(banana split)

然而, cons 的第二个参数不一定是一个列表:

(cons 'heads 'tails) => '(heads . tails)

形式为

(car-part . cdr-part)

的结构称为点对 (dotted pair).

函数 cons, car 和 cdr 以这样一种方式相关联:

(cons (car x) (cdr x)) = x

对任何对 x 都成立.

每个对的 car 部分和 cdr 部分可以是另一个对:

((caar . cdar) . (cdar . cddr))

名称 “caar” 表示 “car part of a car part”, “cdar” 表示 “cdr part of a car part”, 等等.

有一组同名函数可以从嵌套对中提取这些部分:

(caar '((caar . cdar) . (cadr . cddr))) => 'caar
(cdar '((caar . cdar) . (cadr . cddr))) => 'cdar
(cadr '((caar . cdar) . (cadr . cddr))) => 'cadr
(cddr '((caar . cdar) . (cadr . cddr))) => 'cddr

Zenlisp 提供了从最多四层嵌套对中提取数据的函数.

例如, cddddr 提取 cdr4 部分 (从列表的第四个成员开始的尾部), 而 caddr 返回一个数据的 “car of the cdr of the cdr” (恰好是列表的第二个成员):

(cddddr '#abcdef) => '#ef
(caddr '#abcdef) => 'c

提示: 要解码访问嵌套对的函数, 请反向读取其名称中的 a 和 d:

(cadadr '(a (b c) d)) ; remove last 'd', do cdr
-> (cadar '((b c) d)) ; remove last 'a', do car
-> (cadr '(b c))      ; remove last 'd', do cdr
-> (car '(c))         ; do final car
=> 'c

1.5.1 列表
列表是
1. 空列表 ();
2. 或一个其 cdr 部分是列表的对.
listp 谓词测试一个数据是否是列表: ²
1.5.2 形式
每个形式 (form) 要么是一个符号, 要么是一个对.

这些是形式:
```
marmelade
cdr
:f
(heads . tails)
(banana ; this is a comment
 split)
(define (f x) (f (f x)))
(1 2 3 4 . 5)
#hello-world
```
注释可以使用分号放置在形式内的任何位置 (但不能在符号名称内!).

注释延伸到当前行的末尾.

对于某些形式, 有不同的表示法.

列表可以展开为对:
```
(large banana split) = (large . (banana . (split . ())))
```
这样做并没有真正的好理由, 但它表明了

每个列表都是一个对. (但并非每个对都是列表.)

完全由单个字符符号组成的列表可以被压缩:
```
(h e l l o - w o r l d !) = #hello-world!
```
压缩形式很有用, 因为它们更容易理解、更容易输入并节省空间.

你注意到本小节中没有形式被引用吗?

这是因为“形式”是一个抽象术语.

通过应用 quote 伪函数, 一个形式被转换成一个数据 (datum):
```
(quote (banana split)) => '(banana split)
```
但你不必每次想创建一个数据时都使用 quote, 因为
```
'(banana split) => '(banana split)
```
1.5.3 表达式
一个表达式 (expression) 是一个有意义的形式.

在 zenlisp 中, 表达式和程序没有区别.

每个表达式都是一个程序, 每个程序都由一个或多个表达式组成.
```
(car '(fruit salad))
```
是一个提取特定列表第一个成员的程序.
```
(define (palindrome x)
  (append x (reverse x)))
```
是一个有副作用的表达式.

副作用导致某些状态发生改变.

define 的副作用是通过将变量绑定到一个值来创建一个全局定义. 在上面的例子中, 这个值是一个函数.

这个定义被称为“全局的”, 因为它的绑定不发生在特定函数内部.

Define 确实有一个结果, 但它通常被忽略:
```
(define (pizza x) (list 'pizza 'with x)) => 'pizza
```
因为 define 只是为了其副作用而被调用, 所以它被称为伪函数 (pseudo function) 或关键字 (keyword).

伪函数的另一个特性是它们是按名称调用的, 即它们的参数在函数应用之前不会被归约.

这就是为什么 cond 的子句以及 quote 和 define 的参数不必被引用的原因:
```
(cond (:f 'pizza) (t 'sushi))
(quote (orange juice))
(define (f x) (f f x))
```
每个表达式要么是一个变量, 要么是一个 (伪) 函数应用.

1.1.6. 1.6 列表递归

这里是 reverse:

(define (reverse a)
  (cond ((null a) ())
        (t (append (reverse (cdr a))
                   (list (car a))))))

Reverse 反转一个列表.

平凡情况处理空列表, 它根本不需要被反转.

一般情况反转列表的 cdr 部分 (其余部分), 然后将包含原始列表的 car 部分 (第一个成员) 的列表附加到结果上.

这是 reverse 的工作方式:

(reverse '#abc)
-> (append (reverse '#bc) (list 'a))
-> (append (append (reverse '#c) (list 'b)) (list 'a))
-> (append (append (append (reverse ()) (list 'c)) (list 'b))
           (list 'a))
-> (append (append (append () (list 'c)) (list 'b)) (list 'a))
-> (append (append '#c (list 'b)) (list 'a))
-> (append '#cb (list 'a))
=> '#cba

reverse 的参数的每个成员都增加了一次 append 的应用.

这被称为线性递归 (linear recursion).

在许多情况下, 可以通过添加一个携带中间结果的额外参数来避免线性递归.

Reverse 可以这样修改:

(define (reverse2 a r)
  (cond ((null a) r)
        (t (reverse2 (cdr a)
                     (cons (car a) r)))))

(define (reverse a) (reverse2 a ()))

Reverse 现在是 reverse2 的一个“包装器”, 而 reverse2 完成实际工作:

(reverse2 '#abc ())
-> (reverse2 '#bc '#a)
-> (reverse2 '#c '#ba)
-> (reverse2 () '#cba)
=> '#cba

因为在 reverse2 的归约过程中中间结果不会增长, 所以该函数被称为在常数空间 (constant space) 内归约.

这是通过将 reverse 的递归应用重写为尾调用 (tail call) 来实现的.

函数调用 (function call) 与函数应用 (function application) 相同.

尾调用是在尾部位置 (tail position) 的函数调用. 在表达式

(append (reverse (cdr a)) (list (car a)))

中, reverse 不在尾部位置, 因为当 reverse 返回时, append 会被调用.

在表达式

(reverse2 (cdr a) (cons (car a) r))

中, reverse2 在尾部位置, 因为 reverse2 是表达式中最后调用的函数.

顺便说一句, cond 不算, 因为

(cond (t (reverse2 (cdr a) (cons (car a) r))))

可以重写为

(reverse2 (cdr a) (cons (car a) r))

所以:

函数体中最外层的函数处于尾部位置;
cond 主体中最外层的函数处于尾部位置.

一个只在尾部位置使用递归的函数被称为尾递归函数 (tail-recursive function).

尾递归比线性递归更有效率.

这是另一个递归函数, append2:

(define (append2 a b)
  (cond ((null a) b)
        (t (cons (car a)
                 (append2 (cdr a) b)))))

它被称为 append2, 因为它接受两个参数. Append 接受任意数量的参数:

(append '#he '#llo '#- '#wor '#ld) => '#hello-world

但这还不是关于 append2 最糟糕的事情.

Append2 将 (car a) cons 到 append2 的一次应用结果上, 所以它不是尾递归的.

你能写出 append2 的尾递归版本吗?

这里是:

(define (r-append2 a b)
  (cond ((null a) b)
        (t (r-append2 (cdr a)
                      (cons (car a) b)))))

(define (append2 a b)
  (r-append2 (reverse a) b))

这是它的工作原理:

(append2 '#abc '#def)
-> (r-append (reverse '#abc) '#def)
-> (r-append '#cba '#def)
-> (r-append '#ba '#cdef)
-> (r-append '#a '#bcdef)
-> (r-append () '#abcdef)
=> '#abcdef

有什么函数是不能转换成尾递归函数的吗?

是的, 有. 你将在下一章看到其中一些.

1.2. 2. 更有趣的方面

1.2.1. 2.1 可变参数函数

这是 intersection:

(define (intersection a b)
  (cond ((null a) ())
        ((memq (car a) b)
         (cons (car a)
               (intersection (cdr a) b)))
        (t (intersection (cdr a) b))))

它计算两个符号集合的交集:

(intersection '#abcd '#cdef) => '#cd
(intersection '#abcd '#wxyz) => ()

如果你想求两个以上集合的交集, 你必须复合 intersection 的应用:

(define (intersection3 a b c)
  (intersection a (intersection b c)))

要处理可变数量的集合, 你可以将这些集合放在一个列表中传递给函数. intersection-list 就是这样工作的:

(define (intersection-list a*)
  (cond ((null a*) a*)
        ((null (cdr a*)) (car a*))
        (t (intersection (car a*)
                         (intersection-list (cdr a*))))))

Intersection-list 形成列表中包含的所有集合的交集:

(intersection-list '()) => ()
(intersection-list '(#abcd)) => '#abcd
(intersection-list '(#abcd #bcde)) => '#bcd
(intersection-list '(#abcd #bcde #cdef)) => '#cd

这是 list 的代码:

(define (list . x) x)

是的, 就这些. 真的.

List 是一个可变参数函数 (variadic function), 一个接受可变数量参数的函数.

list 变量 (x) 前面的点表示: “将一个包含所有实际参数的列表绑定到该变量”:

(list 'orange) => '(orange)
(list 'orange 'juice) => '(orange juice)
(list 'orange 'juice 'with 'ice) => '(orange juice with ice)

除了是可变参数的, list 是一个普通函数.

因为参数在传递给 list 之前会被归约为它们的范式, 所以列表可以包含动态值:

(list (cons 'heads 'tails) (intersection '#abcde '#cdefg))
=> '((heads . tails) #cde)

当没有参数传递给 list 时, x 被绑定到一个没有参数的列表:

(list) => ()

这是一个接受可变数量集合而非集合列表的 intersection-list 版本:

(define (intersection* . a*)
  (cond ((null a*) a*)
        ((null (cdr a*)) (car a*))
        (t (intersection
            (car a*)
            (apply intersection* (cdr a*))))))

intersection-list 和 intersection* 之间有两个区别:

intersection* 接受可变数量的参数;
intersection* 使用 apply 进行递归.

Apply 将一个函数应用于一个参数列表:

(apply fun (list arg1 ... argn )) = (fun arg1 ... argn )

这里有一些例子:

(apply cons '(heads tails)) => '(heads . tails)
(apply intersection* '(#abc #bcd)) => '#bc
(apply intersection* (cdr '(#abc #bcd))) => '#bcd

Apply 可以用于将函数应用于动态生成的参数列表.

在 intersection* 中, 它将函数应用于参数列表的尾部:

(intersection* '#abc '#bcd '#cde)
-> (intersection '#abc (apply intersection*
                              (cdr '(#abc #bcd #cde))))
-> (intersection '#abc (apply intersection* '(#bcd #cde)))
-> (intersection '#abc (intersection '#bcd
                                    (apply intersection* '(#cde))))
-> (intersection '#abc (intersection '#bcd '#cde))
-> (intersection '#abc '#cd)
=> '#c

顺便说一句, apply 可以安全地用于尾调用.

你能写出 intersection* 的尾递归版本吗?

此时不提供解决方案.

这个函数创建一个非空列表:

(define (non-empty-list first . rest)
  (cons first rest))

当应用于一些实际参数时, 它的行为与 list 相同:

(non-empty-list 'a 'b 'c) => '#abc
(non-empty-list 'a 'b) => '#ab
(non-empty-list 'a) => '#a

不过, 完全不带参数地应用它是未定义的:

(non-empty-list) => bottom

这是因为 non-empty-list 期望至少一个参数.

对于其点分参数列表 (dotted argument list) 中点前面的每个变量,都必须有一个参数:

(non-empty-list first . rest)

First 绑定到第一个参数, 而 rest 绑定到“剩余”参数的列表 (如果有的话).

如果只有一个参数, rest 绑定到 ().

点前面可以有任意数量的参数:

(define (skip-3 dont-care never-mind ignore-me . get-this) get-this)

1.2.2. 2.2 相等性与同一性

所有符号都是唯一的.

因此, 所有名称相同的符号都指向同一个符号:

marmelade marmelade marmelade marmelade marmelade

所有这些名称都指向名为“marmelade”的同一个符号.

同一个符号的两个实例被称为同一的 (identical).

同一性使用 eq 谓词表示:

(eq 'marmelade 'marmelade) => :t
(eq 'fine-cut 'medium-cut) => :f

在 zenlisp 中只有一个空列表, 所以 () 的所有实例也是同一的:

(eq () ()) => :t

但是 eq 能做的还不止这些:

(eq 'symbol '(a . pair)) => :f
(eq 'symbol '(some list)) => :f

当 eq 的一个参数既不是符号也不是 (), 而另一个参数是符号或 () 时, eq 保证归约为假.

这可以被认为是一种“内置类型检查”的方式.

所以, 两个形式是同一的, 如果…

它们表示同一个符号;
它们都是 ().

两个形式不是同一的, 如果其中一个是 pair 而另一个不是.

当 eq 的两个参数都是 pair 时, 结果是未定义的:

(eq '(a . b) '(a . b)) => bottom
(eq '#abcdef '#abcdef) => bottom

注意, 这种情况下的“未定义”意味着结果是完全不可预测的. 将 eq 应用于两个看起来相等的 pair 可能一次产生 :t, 另一次产生 :f.

因此:

永远不要将 eq 应用于两个 pair.

2.2.1 比较更复杂的结构
这两个列表可能相同, 也可能不同:
```
'(bread with butter and marmelade)
'(bread with butter and marmelade)
```
但只需快速浏览一下就足以发现两个列表在相同位置包含相同的符号, 所以它们可以被认为是相等的 (equal).

那这些列表呢:
```
'(bread with (butter and marmelade))
'((bread with butter) and marmelade)
```
尽管这些列表包含相同的符号, 你肯定不会认为它们是相等的, 因为它们包含不同的子列表.

这是一个更好的方法:

两个形式是相等的, 如果…
- 它们都是同一个符号;
- 它们都是 ();
- 它们都是 pair 并且包含相等的 car 和 cdr 部分.
equal 函数测试两个形式是否相等:
```
(define (equal a b)
  (cond ((atom a) (eq a b))
        ((atom b) (eq a b))
        ((equal (car a) (car b))
         (equal (cdr a) (cdr b)))
        (t :f)))
```
只要 eq 返回真, equal 也返回真:
```
(equal 'fine-cut 'fine-cut) => :t
(equal () ()) => :t
```
此外, 当应用于两个看起来相等的 pair 时, 它也返回真:
```
(equal '(bread (with) butter)
       '(bread (with) butter)) => :t
```
因为它递归地进入其参数的 car 和 cdr 部分, 所以即使在嵌套列表中它也能检测到差异:
```
(equal '(bread (with) butter)
       '(bread (without) butter)) => :f
```
因为 equal 确保 eq 只应用于不会导致未定义结果的参数, 所以它可以安全地应用于任何类型的数据.

使用 eq 表示同一性, 使用 equal 表示相等性.

这是 member:
```
(define (member x a)
  (cond ((null a) :f)
        ((equal x (car a)) a)
        (t (member x (cdr a)))))
```
Member 类似于 memq [page 15], 但使用 equal 而不是 eq.

因此, 它可以找到 memq 找不到的成员:
```
(memq '(with) '(bread (with) butter)) => bottom
(member '(with) '(bread (with) butter)) => '((with) butter)
```

1.2.3. 2.3 更多控制结构

or 伪函数的工作方式如下:

(or 'sushi 'pizza 'taco) => 'sushi
(or :f :f 'taco :f) => 'taco
(or :f :f :f) => :f

它返回其参数中第一个不归约为假的参数的范式, 如果所有参数都归约为假, 则返回假.

Or 可以用 cond 来表示:

(or a b)   = (cond (a a) (t b))
(or a b c) = (cond (a a) (b b) (t c))

从这个等价关系可以得出

(or a) = (cond (t a)) = a

此外, 将 or 应用于零个参数会产生逻辑“或”的中性元素:

(or) => :f

and 伪函数的工作方式如下:

(and 'tomato 'lettuce 'bacon) => 'bacon
(and 'tomato :f 'bacon) => :f

它返回其参数中第一个不归约为真的参数, 或者如果所有参数都归约为真, 则返回其最后一个参数的范式.

And 可以用 cond 来表示:

(and a b)   = (cond (a b) (t :f))
(and a b c) = (cond (a (cond (b c)
                               (t :f)))
                    (t :f))

此外:

(and a) = a

将 and 应用于零个参数会产生逻辑“与”的中性元素:

(and) => :t

And 和 or 实现了所谓的短路布尔归约.

它们都在找到一个真值或假值时分别停止对其参数的求值:

(and :f (bottom)) => :f
(or :t (bottom)) => :t

Bottom 是一个求值为 bottom 的函数. 它对传递给它的任何参数的结果都是未定义的:

(bottom) => bottom
(bottom 'foo) => bottom
(bottom 'foo (list 'bar)) => bottom

由于一个称为 bottom 保持 (bottom preservation) 的原则, 每个接受 bottom 参数的函数本身必须归约为 bottom:

(atom (bottom)) => bottom
(eq 'x (bottom)) => bottom
(pizza (bottom)) => bottom

然而, and 和 or 是伪函数, 它们的参数以未归约的形式传递给它们.

因为

and 从不归约任何跟在“假”值后面的参数

并且

or 从不归约任何跟在“真”值后面的参数,

bottom 保持不适用, 所以:

(and :f (bottom)) => :f
(or :t (bottom)) => :t

Bottom 保持不适用于 and, or 和 cond.

通过使用 and 和 or, equal [page 28] 的两个子句可以被节省下来:

(define (equal a b)
  (cond ((or (atom a) (atom b))
         (eq a b))
        (t (and (equal (car a) (car b))
                (equal (cdr a) (cdr b))))))

1.2.4. 2.4 结构递归

这是 replace 函数:

(define (replace old new form)
  (cond ((equal old form) new)
        ((atom form) form)
        (t (cons (replace old new (car form))
                 (replace old new (cdr form))))))

Replace 将 form 中每次出现的 old 替换为 new:

(replace 'b 'x '#aabbcc) => '#aaxxcc
(replace 'old 'new '(old (old) old)) => '(new (new) new)

它可以在任何复杂度的的数据中替换任何复杂度的数据:

(replace '(g x) '(h x) '(f (g x))) => '(f (h x))

为此, 它使用了一种比线性递归更耗费资源的递归.

还记得线性递归吗? 当一个函数必须等待一个递归调用完成时, 就会发生这种情况.

Append2 (首次出现在第 22 页) 是线性递归的, 因为 cons 必须等到对 append2 的递归调用返回:

(define (append2 a b)
  (cond ((null a) b)
        (t (cons (car a)
                 (append2 (cdr a) b)))))

在 replace 中, cons 必须等待两个递归调用的完成.

因此, replace 的中间结果所需的空间增长速度甚至快于线性递归函数所需的空间:

(replace 'b 'x '((a . b) . (c . d)))
-> (cons (replace 'b 'x '(a . b))
         (replace 'b 'x '(c . d)))
-> (cons (cons (replace 'b 'x 'a)
              (replace 'b 'x 'b))
         (cons (replace 'b 'x 'c)
               (replace 'b 'x 'd)))

在最坏的情况下, replace 每次递归时都会增加两个自身的应用. 它必须这样做, 因为在 replace 返回之前, 必须访问一个 pair 的所有原子. 在这种情况下, 函数所需的空间呈指数增长.

因为需要这种递归来处理递归结构, 所以它被称为结构递归 (structural recursion).

当要遍历的结构是“平坦的”—— 比如列表 —— 结构递归并不比线性递归更耗费资源:

(replace 'c 'x '#abc)
-> (cons (replace 'c 'x 'a)
         (replace 'c 'x '#bc))
-> (cons (replace 'c 'x 'a)
         (cons (replace 'c 'x 'b)
               (replace 'c 'x '#c)))
-> (cons (replace 'c 'x 'a)
         (cons (replace 'c 'x 'b)
               (cons (replace 'c 'x 'c) ())))

有什么办法可以处理结构递归吗?

在 replace 的情况下: 没有.

正如其名所示:

遍历递归结构需要结构递归.

需要结构递归的场合并不多.

contains 函数遍历一个递归结构, 但不组合其递归调用的结果:

(define (contains x y)
  (cond ((equal x y) :t)
        ((atom y) :f)
        (t (or (contains x (car y))
               (contains x (cdr y))))))

Contains 类似于 replace: 它的平凡情况返回原子, 而它的一般情况递归两次.

然而, 对 contains 的第二次递归调用是尾调用.

为什么?

当对 contains 的第一次递归调用返回真时, or 甚至不执行第二次调用并立即返回真.

当第一次递归调用返回假时, :f 可以被替换为

(contains x (car y))

在

(or (contains x (car y))
    (contains x (cdr y)))

中, 这导致

(or :f (contains x (cdr y)))

并且因为

(or :f x) = (or x) = x

对 contains 的第二次调用必须始终是尾调用.

or 伪函数只等待第一次递归调用, 这使得 contains 实际上是线性递归的.

第一次递归调用无法消除, 因为它反映了要遍历的结构的固有属性.

出于同样的原因, equal [page 30] 是线性递归的.

1.2.5. 2.5 函数再探

这是一个匿名函数 (anonymous function):

(lambda (topping) (list 'pizza 'with topping))

它等同于命名函数 pizza [page 11]:

((lambda (topping) (list 'pizza 'with topping))
 'pineapple)
=> '(pizza with pineapple)

匿名函数由伪函数 lambda 创建:

(lambda (topping) (list 'pizza 'with topping))
=> {closure (topping)}

Lambda 从匿名函数创建一个闭包 (closure).

由花括号界定的形式是不可读的:

{no matter what} => bottom

它们用于表示没有明确外部表示的数据.

所有的 zenlisp 函数要么是原始函数 (primitive functions), 要么是闭包.

Define, cdr 和 lambda 本身都是原始函数:

define => {internal define}
cdr => {internal cdr}
lambda => {internal lambda}

其他预定义的 zenlisp 函数是闭包:

reverse => {closure #a}
list => {closure x}

list 的代码之前已经展示过:

(define (list . x) x)

这是一个实现 list 的匿名函数:

(lambda x x)

当 lambda 函数的参数列表是单个变量时, 该变量会绑定一个包含所有实际参数的列表.

所以 lambda 函数可以是可变参数的, 就像命名函数一样.

要实现一个期望一些强制性参数的可变参数函数, 使用点分参数列表:

((lambda (x . y) y)) => bottom
((lambda (x . y) y) 'a) => ()
((lambda (x . y) y) 'a 'b) => '#b
((lambda (x . y) y) 'a 'b 'c) => '#bc

Lambda 函数与命名函数完全等价.

事实上, 它们是同一个概念.

(define (pizza top) (list 'pizza 'with top))

只是

(define pizza (lambda (top) (list 'pizza 'with top)))

的简写形式.

命名函数只不过是一个绑定到 lambda 函数的变量.

2.5.1 绑定变量与自由变量
这里是一个定义:
```
(define (f x) (cons x :f))
```
一个出现在函数参数列表中的变量被称为在该函数中是绑定的 (bound).

变量 x 在函数
```
(lambda (x) (cons x :f))
```
中是绑定的, 但变量 cons 在该函数内部不是绑定的.

一个不出现在函数参数列表中但确实出现在同一函数项中的变量被称为在该函数中是自由的 (free).

F 在
```
(lambda (x) (f x))
```
中是自由的.

一个变量被称为在函数中是绑定的, 因为当函数被调用时, 该变量会被绑定到一个值.

但是自由变量得到什么值呢? 这取决于函数的词法上下文 (lexical context).

(lambda (x) (f x)) 的 (词法) 上下文是全局上下文. 全局上下文是 define 绑定其值的上下文.

在全局上下文中, f 被绑定到函数
```
(lambda (x) (cons x :f))
```
通过本节开头的 define. 因此, f 在
```
(lambda (x) (f x))
```
内部被绑定到同一个函数.

顺便说一句: 函数
```
(define (f x) (cons x :f))
```
中的变量 cons 绑定到原始的 cons 函数. zenlisp 的原始函数由系统本身在启动时定义. 它们也定义在全局上下文中.

1.2.6. 2.6 局部上下文

这是一个带有局部上下文的表达式:

(let ((topping-1 'extra-cheese)
      (topping-2 'pepperoni))
  (list 'pizza 'with topping-1 'and topping-2))

变量 topping-1 和 topping-2 是在 let 内部局部创建的.

Let 是一个接受两个参数的伪函数.

第一个参数称为它的环境 (environment), 第二个参数称为它的主体 (body) (或项 (term)).

let 的环境是一个由两个成员组成的列表的列表:

((name1 value1)
 ...
 (namen valuen))

Let 求值所有值, 然后将每个值绑定到与之关联的名称.

项在由将值局部绑定到名称所创建的上下文中求值, 并返回该项的范式:

(let ((x 'heads) (y 'tails))
  (cons x y))
=> '(heads . tails)

这是一个主体是另一个 let 的 let:

(let ((x 'outer))
  (let ((x 'inner)
        (y x))
    (list x y)))
=> '(inner outer)

这个表达式中有两个局部上下文, 一个内部的 (inner) 和一个外部的 (outer).

由 let 创建的上下文称为其内部上下文 (inner context).

let 所在的上下文称为其外部上下文 (outer context).

Let 在其外部上下文中求值其环境的所有值:

(let ((xouter 'outer))
  (let ((xinner 'inner)
        (y xouter))
    (list x y)))
=> '(inner outer)

如果出现重复的符号, 内部 let 的项只能引用该符号的内部实例, 而内部 let 的环境只能引用其外部实例.

顺便说一句, let 只不过是匿名函数应用的另一种语法:

(let ((hd 'heads)       = ((lambda (hd tl)
      (tl 'tails))          (cons hd tl))
  (cons hd tl))         'heads
                         'tails)

这个等价关系很好地解释了为什么环境中的值是在外部上下文中求值的.

你不会期望一个 lambda 函数在其内部上下文中求值其参数, 对吧?

2.6.1 闭包
在嵌套的局部上下文中, 内部的值会遮蔽 (shadow) 外部的值:
```
(let ((v 'outer))
  (let ((v 'inner))
    v))
=> 'inner
```
但是当一个局部变量作为自由变量出现在 lambda 函数中时会发生什么呢?
```
(let ((v 'outer))
  (let ((f (lambda () v)))
    (let ((v 'inner))
      (f))))
=> 'outer
```
你在这里观察到的是一种称为词法作用域 (lexical scoping) 的现象.

函数 f 内部的自由变量 v 的值取决于函数被定义的词法上下文.

f 的定义发生在一个 v 被绑定到 'outer 的上下文中, 函数 f 记住了这个绑定.

v 的重新定义对它没有影响.

一个记住其自由变量词法值的函数被称为闭包 (closure).

这是一个创建闭包的函数:
```
(define (create-conser x)
  (lambda (y) (cons x y)))
```
该函数返回的闭包将其参数 cons 到 x 上.

x 的值在闭包创建时被指定:
```
(define cons-cherry (create-conser 'cherry))
(define cons-lemon (create-conser 'lemon))
```
闭包记住了传递给 create-conser 的参数:
```
(cons-cherry 'pie) => '(cherry . pie)
(cons-lemon 'juice) => '(lemon . juice)
```
好的, 再来一次慢动作:
```
((lambda (x) (lambda (y) (cons x y))) 'lemon)
----> (lambda (y) (cons 'lemon y))
```
这一步被称为 beta 归约 (beta reduction). 它不是 zenlisp 意义上的归约, 而是如上面通用箭头所示的一个更抽象的概念.

Beta 归约将 lambda 函数中在其项中自由的每个变量替换为相应的实际参数:
```
((lambda (y) (cons 'lemon y)) 'juice) -> (cons 'lemon 'juice)
```
Y 在 (cons 'lemon y) 中是自由的, 所以它被替换为与 x 关联的值.

这里情况有所不同:
```
((lambda (x) (lambda (x) x)) 'foo) ----> (lambda (x) x)
```
因为 x 在 (lambda (x) x) 中是绑定的, 所以它不会被 'foo 替换.

这是一个混合场景:
```
((lambda (x) (list x (lambda (x) x))) 'foo) ----> (list 'foo (lambda (x) x))
```
第一个 x 是自由的, 因此被替换; 第二个 x 在一个函数中是绑定的, 因此保持不变.

Beta 归约是 lambda 演算 (LC) 的一种变换. LC 是所有 LISPy 语言的数学基础.

Beta 归约是 zenlisp 函数调用中闭包和参数绑定的一个形式化模型.
2.6.2 递归函数
这是一个简单的函数:
```
(define (d x)
  (or (atom x) (d (cdr x))))
```
无论你给 d 传递什么, 它总是返回 :t:
```
(d 'x) => :t
(d '#xyz)
-> (d '#yz)
-> (d '#z)
-> (d ())
=> :t
```
这是一个不那么简单的问题:

如果 lambda 封闭了其所有的自由变量, 并且
```
(define (d x) (or (atom x) (d (cdr x))))
```
等价于
```
(define d (lambda (x) (or (atom x) (d (cdr x)))))
```
那么在 d 被绑定到结果闭包之前, lambda 必须封闭 d.

那么 d 如何递归呢?

显然, 它可以.

答案是 d 根本不是一个真正的闭包 (尽管它看起来像).

每当 define 将一个名称绑定到一个 lambda 函数时, 它会阻止 lambda 捕获其自由变量.

结果是一个带有空环境的闭包.

因为绑定到 d 的函数没有 d 的局部值, 它会求助于 d 的全局绑定.

这种方法被称为动态作用域 (dynamic scoping). 它被称为“动态的”, 因为它允许动态地改变自由变量的值.

这是动态作用域的一个例子:
```
(define food 'marmelade)
(define (get-food) food)
(get-food) => 'marmelade
(define food 'piece-of-cake)
(get-food) => 'piece-of-cake
```
因为动态作用域允许在函数中使用符号之后再将值绑定到这些符号, 所以它甚至可以用来创建相互递归的函数:
```
(define (d1 x) (or (atom x) (d2 (cdr x))))
(define (d2 x) (or (atom x) (d1 (cdr x))))
(d1 '#xyz) => :t
```
如果函数 f 调用 g 并且 g 调用 f, 则两个函数 f 和 g 是相互递归的.

顺便说一句, 你可以使用一个带有空环境的 let 来让 define 创建一个闭包:
```
(define food 'marmelade)
(define get-food (let () (lambda () food)))
(get-food) => 'marmelade
(define food 'piece-of-cake)
(get-food) => 'marmelade
```
然而, 这种方法使得递归函数变得不可能:
```
(define dc (let () (lambda (x)
                    (or (atom x)
                        (dc (cdr x))))))
(dc '#xyz) => bottom
```

2.6.3 递归闭包

Let 可以绑定平凡的函数:

(let ((cons-lemon
       (lambda (x)
         (cons 'lemon x))))
  (cons-lemon 'cake))
=> '(lemon . cake)

Let 不能绑定递归函数, 因为函数在被绑定到其名称之前就封闭了其自身的名称:

(let ((d (lambda (x)
           (or (atom x)
               (d (cdr x))))))
  (d '#xyz))
=> bottom

Letrec 可以绑定递归函数:

(letrec ((d (lambda (x)
              (or (atom x)
                  (d (cdr x))))))
  (d '#xyz))
=> :t

这就是为什么它被称为 letrec.

使用 letrec, 像 reverse [page 21] 这样的函数可以被打包在一个单独的 define 中:

(define (reverse a)
  (letrec
    ((reverse2
       (lambda (a r)
         (cond ((null a) r)
               (t (reverse2 (cdr a)
                            (cons (car a) r)))))))
    (reverse2 a ())))

甚至相互递归也可以用 letrec 来实现:

(letrec ((d1 (lambda (x)
               (or (atom x) (d2 (cdr x)))))
         (d2 (lambda (x)
               (or (atom x) (d1 (cdr x))))))
  (d1 '#xyz))
=> :t

let 和 letrec 之间唯一的区别是, letrec 在将值绑定到符号后, 会在其环境中修复递归引用.

因此

局部函数应该由 letrec 绑定, 局部数据由 let 绑定.

2.6.4 递归绑定
这是一个归约为闭包的表达式:
```
(lambda () f)
```
该闭包的应用归约不到任何值, 因为 f 没有值:
```
((lambda () f)) => bottom ; make sure that F is unbound!
```
Zenlisp有一组修改解释器状态的元函数 (meta functions). 元函数应用
```
(closure-form env)
```
使得解释器在打印闭包的范式时显示它们的词法环境:
```
(lambda () f) => (closure () f ((f . {void})))
```
闭包以圆括号打印, 因为它的完整表示是无歧义的.

现在闭包的四个部分都会打印出来: closure 关键字、参数列表、主体以及被 lambda 捕获的词法环境.

环境存储在一个关联列表 (association list, 又名 alist) 中.

关联列表是 pair 的列表, 其中每个 pair 的 car 部分是一个键, 每个 cdr 部分是与该键关联的值:
```
((key1 . value1) ... (keyn . valuen))
```
在词法环境中, 变量名是键, 与这些键关联的值是这些变量的值.

assq 和 assoc 函数用于从 alist 中检索关联:
```
(define alist '((food . orange) (drink . milk)))
(assq 'drink alist) => '(drink . milk)
(assq 'soap alist) => :f
```
Assoc 与 assq 的关系就像 member 与 memq [page 15] 的关系一样:
```
(assq '(key) '(((key) . value))) => :f
(assoc '(key) '(((key) . value))) => '((key) . value)
```
闭包 alist 的问题
```
(closure () f ((f . {void})))
```
在于 f 没有与任何特定的值关联 —— 即使闭包本身与符号 f 关联 (形式 {void} 表明 f 根本没有被绑定):
```
(let ((f (lambda () f))) f)
=> (closure () f ((f . {void})))
```
我们意在引用内部的 f, 但 lambda 封闭了外部的 f.

Letrec 使用一个名为 recursive-bind 的函数来修复包含递归引用的环境:
```
(recursive-bind '((f . (closure () f ((f . wrong))))))
```
f 在内部上下文中绑定到什么并不重要, 因为这正是 recursive-bind 将要改变的.

在结果结构中, wrong 被替换为对外部 f 值的引用:
```
(recursive-bind '((fouter . (closure () finner ((finner . wrong))))))
=> '((fouter . (closure () finner ((finner . fouter)))))
```
因为 f 现在包含一个对 f 的引用, 它是一个循环结构.

当你用 closure-form 设置为 env 归约上述 recursive-bind 的应用时, 解释器将尝试打印一个无限结构:
```
(recursive-bind '((f . (closure () f ((f . wrong))))))
=> '((f . (closure () f
           ((f . (closure () f
                  ((f . (closure () f
                         ((f . ...
```
这就是为什么默认情况下只打印闭包的参数列表. 你可以通过应用
```
(closure-form args)
```
来恢复这种行为.

1.2.7. 2.7 高阶函数

这是一个高阶函数 (higher-order function):

(define (compose f g)
  (lambda x (f (apply g x))))

高阶函数是接受一个函数作为参数和/或归约为一个函数的函数.

之前介绍的 create-conser 函数 [page 37] 也是一个高阶函数.

compose 函数接受两个函数 f 和 g 作为参数, 并创建一个实现 f 和 g 复合的匿名函数.

cadr 函数, 它提取列表的第二个元素, 可以用 compose 来实现:

(compose car cdr) => {closure #x}
((compose car cdr) '(pizza with pepperoni)) => 'with

当然, 你可能会这样写 cadr:

(define (cadr x) (car (cdr x)))

所以这里有一个更有趣的例子.

Filter 从一个扁平列表中提取具有给定属性的成员. 通过对每个成员应用谓词 p 来测试该属性: ³

2.7.1 映射
Map 将函数映射到列表上:
```
(map (lambda (x) (cons 'lemon x))
     '(cake juice fruit))
=> '((lemon . cake) (lemon . juice) (lemon . fruit))
```
Map 同时实现了列表操作和流程控制.

这是一个使用 map 来计算列表深度的函数: ⁴
2.7.2 折叠
Fold 通过组合相邻成员来折叠列表:
```
(fold cons 'a '(b c d)) => '(((a . b) . c) . d)
```
fold 的第一个参数是用于组合元素的函数, 第二个参数是“基”元素, 第三个是要组合的元素列表. 基元素与列表的第一个成员组合.

当成员列表为空时, fold 返回基元素:
```
(fold cons 'empty ()) => 'empty
```
Fold 用于遍历列表.

Predicate-iterator 是一个高阶函数, 它使用 fold 使一个双参数谓词变为可变参数 ⁵ (Neq is (compose not eq)):

1.3. 3. 更深奥的方面

1.3.1. 3.1 数值函数

在 zenlisp 程序能够处理数字之前, 它必须 require 其中一个数学包:

(require '~nmath)

Nmath 是一个包含用于自然数 (加零) 计算的函数的包.

Zenlisp 使用数字列表来表示自然数. 以下是一些例子:

'#0 '#3 '#1415 '#926535

这是 length 函数:

(define (length x)
  (letrec
    ((length2
       (lambda (x r)
         (cond ((null x) r)
               (t (length2 (cdr x) (+ '#1 r)))))))
    (length2 x '#0)))

Length 计算列表的长度:

(length ()) => '#0
(length '(orange juice)) => '#2
(length '#4142135623) => '#10

它使用数学函数 +, 该函数用于数字相加:

(+) => '#0
(+ '#5) => '#5
(+ '#5 '#7) => '#12
(+ '#5 '#7 '#9) => '#21

像许多其他数学函数一样, + 是可变参数的.

向 + 传递零个参数会产生 '#0, 即数学“加”运算的中性元素.

这里还有一些其他的数学函数:

(*) => '#1
(* '#5 '#7 '#9) => '#315
(- '#7 '#3 '#4) => '#0

函数计算其参数的乘积, - 计算它们的差.

整数除法由 divide 函数执行:

(divide '#17 '#3) => '(#5 #2)

它返回一个列表, 包含其参数的整数商和除法余数:

(divide dividend divisor) => '(quotient remainder)

当只关心两个数的商或余数时, quotient 和 remainder 函数很有用:

(quotient '#17 '#3) => '#5
(remainder '#17 '#3) => '#2

两个数 a 和 b 的除法余数定义为

(- a (* (quotient a b) b))

(Expt x y) 计算 x 的 y 次方:

(expt '#3 '#100) => '#515377520732011331036461129765621272702107522001

因为 zenlisp 将数字实现为数字列表, 所以精度仅受时间和内存的限制.

这种方法被称为大数算术 (bignum arithmetics). 它保证数值表达式总是产生一个数学上正确的结果 (当然, 这也包括返回 bottom 的可能性).

3.1.1 数值谓词
这是 ngcd 函数的代码:
```
(define (ngcd a b)
  (cond ((zero b) a)
        ((zero a) b)
        ((< a b) (ngcd a (remainder b a)))
        (t (ngcd b (remainder a b)))))
```
Ngcd 计算两个自然数的最大公约数:
```
(ngcd '#12 '#6) => '#6
(ngcd '#289 '#34) => '#17
(ngcd '#17 '#23) => '#1
```
当然, 你会使用 zenlisp 数学包中的 gcd 函数来计算 gcd, 但 ngcd 使用了两个有趣的函数.

zero 函数测试其参数是否等于数字 0:
```
(zero '#0) => :t
(zero '#1) => :f
```
zero 的参数必须是一个数字:
```
(zero 'non-number) => bottom
```
Zero 是一个数值谓词.

它可以用另一个数值谓词来表示 (尽管效率较低):
```
(define (zero x) (= x '#0))
```
= 谓词测试其参数在数值上是否相等:
```
(= '#3 '#3 '#3) => :t
(= '#23 '#17) => :f
```
这里还有一些其他的数值谓词:
```
(< '#1 '#2 '#3) => :t
(> '#3 '#2 '#1) => :t
(<= '#1 '#2 '#2) => :t
(>= '#2 '#1 '#1) => :t
```
它们分别测试“小于”、“大于”、“小于或等于”和“大于或等于”的属性.

对于每个比较数值谓词 R, 以下关系成立:
```
(R a1 ... an) = (and (R a1 a2) ... (R an-1 an))
```
所以, 例如,
```
(< a b c d)
```
可以写成
```
(and (< a b) (< b c) (< c d))
```
这正是为什么没有负等价运算符的原因.

如果存在这样的运算符 (我们称之为 not=), 表达式
```
(not= a1 ... an)
```
将转化为
```
(and (not= a1 a2) ... (not= an-1 an))
```
而
```
(not (and (= a1 an2) ... (= an-1 an)))
```
等于
```
(or (not= a1 a2) ... (not= an-1 an))
```
3.1.2 整数函数
当使用 nmath 包时, 不会出现负数结果:
```
(- '#0 '#1) => bottom
```
加载 imath (整数数学) 包将自然数数学函数的定义域和/或值域扩展到包括负数:
```
(require '~imath)
(- '#0 '#1) => '#-1
```
加载 imath 会自动加载 nmath.

加载整数数学包后, 前一节讨论的大多数函数也接受负数参数:
```
(+ '#5 '#-7) => '#-2
(* '#-5 '#-5) => '#25
(quotient '#17 '#-3) => '#-5
```
- 函数被扩展以处理单个参数, 实现了“取反”运算符:
```
(- '#27182) => '#-27182
```
除了 remainder 函数, imath 还引入了 modulo 函数. a 和 b 的模定义为: ⁶ \[ a - \text{floor}(a/b) \times b \] remainder 和 modulo 的结果仅在它们的参数 a 和 b 符号不同时才有所不同:

argument a argument b remainder modulus

'#+23 '#+5 '#+3 '#+3

'#+23 '#-5 '#+3 '#-2

'#-23 '#+5 '#-3 '#+2

'#-23 '#-5 '#-3 '#-3

因为 zenlisp 缺少“floor”函数, modulo 利用了这样一个事实:
```
(modulo x y) = (+ y (remainder x y))
```
如果 x 和 y 的符号不同.

这里是 modulo:
```
(define (modulo a b)
  (let ((rem (remainder a b)))
```
3.1.3 有理数函数
当使用 imath 包时, 零和一之间的结果不会出现:
```
(expt '#2 '#-5) => bottom
```
加载 rmath (有理数数学) 包将整数数学函数的定义域和/或值域扩展到包括有理数:
```
(require '~rmath)
(expt '#2 '#-5) => '#1/32
```
有理数的格式是
```
'#numerator/denominator
```
其中 numerator 和 denominator 是整数.

负有理数有一个负的分子:
```
(- '#1 '#3/2) => '#-1/2
```
numerator 和 denominator 函数提取有理数的各个部分:
```
(numerator '#-5/7) => '#-5
(denominator '#-5/7) => '#7
```
即使加载了 rmath 包, divide 和 quotient 函数仍然执行整数除法. / 函数执行有理数的除法:
```
(/ '#10 '#2) => '#5
(/ '#20 '#6) => '#10/3
(/ '#1/2 '#1/2) => '#1
```
nmath 包的 sqrt 函数提供一个数的平方根的整数部分. Rmath 扩展此函数以提供一个有理数结果:
```
(sqrt '#144) => '#12
(sqrt '#2) => '#665857/470832
```
有理数 sqrt 函数的精度由 epsilon 变量控制:
```
*epsilon* => '#10
```
例如, 一个值为 5 的 epsilon 表示 $10^{-5}$ 的精度, 即当转换为定点表示法时, sqrt 的结果至少有 5 位小数的精度. 默认精度是 $10^{-10}$.
3.1.4 类型检查与转换
number-p 谓词检查一个数据是否表示一个数字:
```
(number-p '#314) => :t
(number-p '#-159) => :t
(number-p '#-265/358) => :t
```
任何类型的数据都可以传递给 number-p:
```
(number-p 'marmelade) => :f
(number-p '(heads . tails)) => :f
```
natural-p, integer-p, 和 rational-p 谓词测试一个数字是否具有特定类型:
```
(natural-p '#1) => :t
(integer-p '#-1) => :t
(rational-p '#1/2) => :t
```
传递给这些谓词之一的数据必须是一个有效的数字:
```
(integer-p 'sushi) => bottom
```
还要注意, 这些谓词只检查传递给它们的数据的语法. 因此
```
(natural-p '#+1) => :f
(integer-p '#1/1) => :f
(rational-p '#5) => :f
```
尽管 '#1/1 是一个整数值, integer-p 并不识别它, 因为它具有有理数的语法.

要检查一个数字的值是否具有特定类型, 代表该数字的数据必须首先被规范化 (normalized). 这可以通过应用一个中性操作来完成:
```
(natural-p (+ '#0 '#+1)) => :t
(integer-p (* '#1 '#1/1)) => :t
```
然而, 这仅在参数具有比被检查类型“更复杂”的语法时才有效:
```
(rational-p '(+ '#0 '#5)) => :f
```
尽管 '#5 是一个有效的有理数, rational-p 并不返回真, 因为 '#5 的规范化形式仍然是 '#5 而不是 '#5/1.

这就是规范化的作用:
- 将有理数约分为最简形式;
- 将有理数的符号移至分子;
- 移除分母为 1;
- 从整数中移除正号;
- 移除前导零.
规范化将每个数字归约为其最适用的类型.

有理数是整数的超集, 整数是自然数的超集.

一个数字的最小类型是包含该数字的最小集合所代表的类型.

例如, '#-5/-5 是一个有理数, 但规范化它会产生一个自然数:
```
(+ '#0 '#-5/-5)
-> '#-5/-5     ; added '#0
-> '#1/1       ; reduced to least terms
=> '#1         ; removed denominator of '#1
```
natural, integer, 和 rational 函数试图将一个数字转换为不同的类型:
```
(natural '#+5) => '#5
(integer '#5) => '#5
(rational '#-5) => '#-5/1
```
如果请求的转换无法完成, 这些函数将归约为 bottom, 从而实现数值类型检查:
```
(natural '#-1) => bottom
(integer '#1/2) => bottom
```
需要 rmath 包才能使以下类型转换工作:
```
(require '~rmath)
(integer '#4/2) => '#2
```
当仅使用 imath 时, 它将不起作用:
```
(require '~imath)
(integer '#4/2) => bottom
```
类型转换函数用于保护函数免受其定义域之外的参数的影响.

这是一个将双参数数学函数转换为可变参数数学函数的高阶函数:
```
(define (arithmetic-iterator conv fn neutral)
  (lambda x
    (cond ((null x) neutral)
          (t (fold (lambda (a b)
                     (fn (conv a) (conv b)))
                   (car x)
                   (cdr x))))))
```
fn 参数是要转换的函数, conv 是类型转换函数之一, neutral 是 fold 的基值.

设 n+ 是一个用于加法自然数的无保护二元函数 (一个接受两个变量的函数):
```
(n+ '#1 '#2) => '#3
(n+ '#+1 '#+2) => bottom
(n+ '#1 '#2 '#3) => bottom
```
Arithmetic-iterator 将这个函数变成一个受保护的可变参数函数:
```
((arithmetic-iterator natural n+ '#0) '#+1 '#+2 '#+3) => '#6
((arithmetic-iterator natural n+ '#0) '#+0 '#-1) => bottom
```
Arithmetic-iterator 实际上用于实现 zenlisp 的大多数数学函数.

argument a	argument b	remainder	modulus
'#+23	'#+5	'#+3	'#+3
'#+23	'#-5	'#+3	'#-2
'#-23	'#+5	'#-3	'#+2
'#-23	'#-5	'#-3	'#-3

1.3.2. 3.2 副作用

函数的效果 (effect) 是将值映射到值:

(null ()) => :t
(null x) => :f ; for any x that does not equal ()

null 的效果是将 () 映射到 :t, 将任何其他值映射到 :f.

每次将一个函数应用于相同的实际参数时, 它都会返回相同的结果:

(atom 'x) => :t
(atom 'x) => :t
(atom 'x) => :t

这是一个函数的基本属性.

无法通过将值映射到值来解释的效果称为副作用 (side effect).

Define 被认为有副作用:

(define marmelade 'medium-cut-orange) => 'marmelade
marmelade => 'medium-cut-orange
(define marmelade 'fine-cut-orange) => 'marmelade
marmelade => 'fine-cut-orange

变量 marmelade 的值的突变无法通过将 marmelade 和 'fine-cut-orange 映射到 'marmelade 来解释. Define 甚至不会为每对参数提供相同的值: ⁷

3.2.1 微妙的副作用
cons 和 eq 都没有副作用, 但通过稍微变通一下规则, 它们可以被用来构造一个副作用.

Cons 保证返回一个新的 pair.

Eq 通过比较数据在计算机内存中的位置来比较数据. 当然, 这是一个实现细节. 你不需要记住它, 但它的含义很有趣:
```
(eq (cons x y) (cons x y)) => :f for any values of x and y.
```
这是将两个 pair 传递给 eq 会产生 bottom 这一规则的例外:

cons 的两次应用永远不会产生相同的结果.

因此, cons 可以创建一个数据的绝对唯一的实例:
```
(define unique-instance (cons 'unique-instance ()))
```
而 eq 可以识别该实例:
```
(eq unique-instance unique-instance) => :t
(eq unique-instance '(unique-instance)) => :f
unique-instance => '(unique-instance)
```
这种效果无法通过将值映射到值来解释, 所以它显然是一个副作用.

创建唯一实例是这里描述此副作用的唯一原因. 它可以用来克服 predicate-iterator 函数 [page 45] 的一个微妙限制.

Predicate-iterator 使用符号 :fail 来表示失败. 因此, 当它返回的函数被应用于 ':fail 本身时, 它可能会提供一个错误的值:
```
((predicate-iterator equal) ':fail ':fail) => :f
```
无论你在 :fail 的位置发明什么符号, 由 predicate-iterator 创建的函数都永远无法正确处理该符号.

你需要的是一个代表失败的数据的唯一实例:
```
(define (predicate-iterator pred)
  (let ((:fail (cons ':fail ())))
    (let ((compare
           (lambda (a b)
             (cond ((eq a :fail) :fail)
                   ((pred a b) b)
                   (t :fail)))))
      (lambda (first . rest)
        (neq (fold compare first rest) :fail)))))
```
在改进版的 predicate-iterator 中, :fail 绑定到 '(:fail) 的一个唯一实例. 因此, 该函数甚至可以正确处理该数据的其他实例:
```
((predicate-iterator equal) '(:fail) '(:fail)) => :t
```
3.2.2 求值
eval 函数解释 zenlisp 表达式:
```
(eval '(letrec
         ((n (lambda (x)
               (cond ((atom x) ())
                     (t (cons 'i (n (cdr x))))))))
         (n '(1 2 3 4 5))))
=> '#iiiii
```
注意, eval 的参数是一个列表, 因此在传递给 eval 之前不会被求值. 正是 eval 函数赋予了一个形式意义, 从而将其变成一个表达式.

如果传递给它的数据不构成一个有效的表达式, Eval 将归约为 bottom:
```
(eval '(cons 'x)) => bottom
```
如果由它解释的表达式有副作用, Eval 也有副作用:
```
(eval '(define bar 'foo)) => 'bar
bar => 'foo
```

1.3.3. 3.3 元编程

这是一个微不足道的元程序:

(list 'lambda '(x) 'x) => '(lambda (x) x)

元程序 (metaprogram) 是编写或重写程序的程序.

程序是表达式, 而表达式是形式的子集.

每个程序都可以通过引用它来变成一个数据:

(quote (lambda (x) x)) => '(lambda (x) x)

这是另一个简单的元程序:

((lambda #x (list x (list 'quote x)))
 '(lambda #x (list x (list 'quote x))))

这种程序的有趣之处在于它的范式等于它自己的代码; 它归约到自身: ⁸

3.3.1 程序修改程序

这是一个不那么微不足道的元程序:

(define (let->lambda let-expr)
  (let ((env (cadr let-expr)))
    (let ((vars (map car env))
          (args (map (lambda (x) (unlet (cadr x)))
                     env))
          (body (unlet (caddr let-expr))))
      (append (list (list 'lambda vars body))
              args))))

(define (unlet x)
  (cond ((atom x) x)
        ((eq (car x) 'quote) x)
        ((eq (car x) 'let) (let->lambda x))
        ((eq (car x) 'lambda)
         (list 'lambda
               (cadr x)
               (unlet (caddr x))))
        (t (map unlet x))))

Let->lambda 将 (一个代表) let 表达式转换为 (一个代表) lambda 函数的应用:

(let->lambda '(let ((x 'heads)
                    (y 'tails))
                (cons x y)))
=> '((lambda #xy
     (cons x y))
   'heads 'tails)

unlet 函数遍历 (一个代表) zenlisp 表达式, 并替换其中包含的每个 let:

(unlet '(let ((y (let ((a '(orange)))
                   a))
              (z '(cookies)))
          (let ((x '(i like)))
            (append x y z))))
=> '((lambda #yz
     ((lambda #x
       (append x y z))
      '(i like)))
    ((lambda #a a)
     '(orange))
    '(cookies))

如果说别的没有, 这个程序表明 let 在某些情况下比 lambda 更具可读性.

Unlet 通过 map 进行递归. 通过 map 的递归总是一种结构递归.

顺便说一句, 默认情况 (map unlet x) 不能被

(cons (unlet (car x))
      (unlet (cdr x)))

替换, 因为这样做会破坏对引用的测试. 给定

x = '(list quote x)

上面的解决方案将导致

(cons (unlet 'list)
      (unlet '(quote x)))

这反过来会导致 unlet 将 x 视为一个被引用的符号, 而它不是.

3.3.2 通过替换实现 Beta 归约
本节介绍一个稍微更复杂的元程序.

Lambda-rename 重命名 lambda 表达式的变量, 以便每个变量都有一个唯一的名称:
```
(lambda-rename '(lambda (x) (lambda (y) (cons x y))))
=> '(lambda (x:0) (lambda (y:1) (cons x:0 y:1)))
```
其目的是解决变量之间的冲突:
```
(lambda-rename '(lambda (x) (list x (lambda (x) x))))
=> '(lambda (x:0) (list x:0 (lambda (x:1) x:1)))
```
Lambda-rename 使用了一些辅助函数.

add 函数将一个冒号和一个数字添加到符号名称中:
```
(require '~nmath) ; this will be needed later
(define (add name level)
  (implode (append (explode name)
                   '#:
                   level)))
```
它使用 implode 函数从单个字符名称的列表中创建一个新的符号名称:
```
(implode '(n e w - n a m e)) => 'new-name
```
Zenlisp 数字已经是符号列表:
```
(cons 'digits: '#31415) => '(digits: 3 1 4 1 5)
```
为了将 '#: 和一个数字附加到一个现有的符号, 现有的符号必须首先被展开.

explode 函数实现了 implode 的反向操作: ⁹

1.3.4. 3.4 包

这是一个 zenlisp 包:

(define square :t)         ; name the package
(require '~rmath)          ; declare dependencies
(define (square x) (* x x)) ; package body

require 函数仅在给定名称未被绑定时加载具有该名称的包.

例如

(require '~rmath)

仅在符号 rmath 未绑定到任何值时加载 rmath. 如果该符号已被绑定, require 会假定该包已经加载.

前导波浪号 (“~”) 使 zenlisp 从标准位置加载一个包.

因为 require 只加载一次包, 所以递归引用不会造成问题. 加载一个名为 foo.l 的文件, 其中包含包

(define foo :t)
(require 'foo) ; require myself

只会加载 foo. 不会发生无限递归.

2. 第二部分算法

2.1. 4. list 函数

2.1.1. 4.1 heads and tails

为了热身, 你如何判断列表 x 是否是列表 y 的头部, 例如:

(headp '#a '#abc) => :t
(headp '#ab '#abc) => :t
(headp '#abc '#abc) => :t
(headp '#abcd '#abc) => :f

如果列表 x 的前导成员直到 x 的长度都与 y 相等, 那么 x 就是 y 的头部. 这是执行此测试的 headp:

(define (headp x y)
  (cond ((null y) (null x))
        ((null x) :t)
        (t (and (equal (car x) (car y))
                (headp (cdr x) (cdr y))))))

根据 headp, 空列表是任何列表的头部:

(headp () '(foo bar baz)) => :t

你认为这是处理空“头部”的正确方法吗？如果是, 为什么？如果不是, 为什么不？列表的 car 部分也被称为列表的“头部”, 这一事实如何引发了这场争议？(Q1)

趁热打铁: 你将如何检查列表 x 是否是列表 y 的尾部. 不用想太久:

(require 'headp)
(define (tailp x y)
  (headp (reverse x) (reverse y)))

为什么这个事实

(tailp () '#whatever) => :t

比这个事实

(headp () '#whatever) => :t

争议更小？

附加练习: 为 headp 和 tailp 找到更好的名字.

2.1.2. 4.2 找到列表的第 n 个尾部

nth 函数提取从列表第 n 个元素开始的尾部. 当列表太短时, 它返回 :f:

(nth '#0 '#abc) => '#abc
(nth '#1 '#abc) => '#bc
(nth '#2 '#abc) => '#c
(nth '#5 '#abc) => :f

这是 nth 的代码:

(require '~nmath)

(define (nth n x)
  (cond ((zero n) x)
        ((null x) :f)
        (t (nth (- n '#1)
                (cdr x)))))

当参数 n 等于列表长度时, nth 返回一个空列表. 特别是:

(nth '#0 ()) => ()

当你交换 nth 的 cond 的前两个谓词时, 在上述情况下它将返回 :f. 你认为哪个版本更一致？为什么？

你认为列表的第一个成员的偏移量为 '#0 是个好主意吗？实现一个从 '#1' 开始编号成员的版本. 每个版本的优缺点是什么？当你给你的版本传递一个零偏移量时, 它会返回什么？

2.1.3. 4.3 计算一个形式中的原子数量

count 函数递归地计算一个形式中的原子数量:

(count ()) => '#0
(count 'a) => '#1
(count '(a (b (c) d) e)) => '#5

这是 count 函数的代码:

(require '~nmath)

(define (count x)
  (cond ((null x) '#0)
        ((atom x) '#1)
        (t (+ (count (car x))
              (count (cdr x))))))

严格来说, count 只计算一个形式中的符号, 因为 () 也是一个原子. 不过, 如果 count 对 () 返回 '#1, 其结果将是反直觉的. 为什么？(Q2)

Count 使用结构递归. 你认为它可以被写得更有效率吗？

这是一个有趣的问题. 这里是一个完全使用尾调用的 count 版本:

(require '~nmath)

(define (count1 x)
  (letrec
    ((c (lambda (x r s)
          (cond ((null x)
                 (cond ((null s) r)
                       (t (c (car s) r (cdr s)))))
                ((atom x)
                 (c () (+ '#1 r) s))
                (t (c (car x) r (cons (cdr x) s)))))))
    (c x '#0 ())))

它使用内部函数 c, 将其（到目前为止计数的原子）中间结果保存在额外参数 r 中. 这种技术在本书前面部分用于将线性递归程序转换为尾递归程序. 这种技术也可以用于将结构递归转换为尾递归吗？

c 函数使用一个额外的参数 s, 它存储了将来要访问的节点. 每当它找到一个新的 pair 时, 它就将其 cdr 部分保存在 s 中, 然后开始遍历该 pair 的 car 部分.

当 count 找到 () 的一个实例时, 它会移除 s 的头部并遍历存储在那里的结构. 当然, 名称 s 应该会让人联想到“栈”, 而这正是它的本质.

结构递归版本和使用尾调用的版本之间的唯一区别是, 使用尾调用的版本将激活记录存储在一个显式栈上, 而不是在 zenlisp 的内部栈上. 递归本身无法被移除. 它是问题固有的.

这个特例很好地说明了, 试图从固有递归问题的解决方案中移除递归, 通常会降低可读性, 而效率提升甚微.

2.1.4. 4.4 扁平化一棵树

一棵树通过将其变成一个包含相同成员且顺序相同的扁平列表而被“扁平化”:

(flatten '((a) (b (c)) (d (e (f))))) => '#abcdef

这是 flatten1 的代码, 它执行此操作 — 尽管效率非常低:

(define (flatten1 x)
  (cond ((null x) x)
        ((atom x) (list x))
        (t (append (flatten1 (car x))
                   (flatten1 (cdr x))))))

你能说出几个为什么这个实现效率远不高的原因吗？(是的, 明显的结构递归只是其中之一.)

这是一个改进的版本. 它使用了一个巧妙的技巧来避免结构递归:

(define (flatten x)
  (letrec
    ((f (lambda (x r)
          (cond ((null x) r)
                ((atom x) (cons x r))
                (t (f (car x)
                      (f (cdr x) r)))))))
    (f x ())))

该函数仍然应用自身两次, 但第一次应用的结果被传递给第二次, 这是一个尾调用, 从而将结构递归转变为线性递归.

这个版本的 flatten 能否被转换为使用尾调用的版本, 就像 count 一样？这种转换会进一步提高效率吗？(Q3)

2.1.5. 4.5 分割列表

在前面的部分中, 介绍了函数 filter 和 remove [page 42]. 一个函数提取满足谓词的成员, 另一个函数移除满足谓词的成员.

你能写一个结合了 filter 和 remove 功能的程序吗？提示: 该函数应返回两个列表.

这是 partition 的代码, 它将一个列表分割成满足和不满足给定谓词的成员:

(define (partition p a)
  (letrec
    ((partition3
       (lambda (a r+ r-)
         (cond ((null a)
                (list r+ r-))
               ((p (car a))
                (partition3 (cdr a)
                            (cons (car a) r+)
                            r-))
               (t (partition3 (cdr a)
                              r+
                              (cons (car a) r-)))))))
    (partition3 (reverse a) () ())))

其结果的第一个成员等于 filter 的输出, 第二个成员类似于 remove 的输出. 在 partition 的基础上实现 filter 和 remove 有意义吗？

2.1.6. 4.6 在多个列表上折叠

fold 函数 (在第 45 页解释, 代码在第 271 页) 将列表折叠成值:

(fold (lambda (x y) (list 'op x y)) '0 '(a b c))
=> '(op (op (op 0 a) b) c)

Revised6 Report on the Algorithmic Language Scheme (R6RS) — 尽管备受争议 — 定义了一些有趣的函数. 其中之一是 fold-left, 它允许在多个列表上折叠:

(fold-left (lambda (x y z) (list 'op x y z))
           '0
           '(a b c)
           '(d e f))
=> '(op (op (op 0 a d) b e) c f)

所有列表必须具有相同的长度. 你能实现 fold-left 吗？提示: 这个函数与 map [page 44] 和 fold 有一些共同之处. 特别是, 以下函数在实现它时很有帮助:

(define (car-of a) (map car a))
(define (cdr-of a) (map cdr a))

事实上, fold-left 和 fold 完全一样, 但它使用了 map 的技术来处理可变参数:

(define (fold-left f b . a*)
  (letrec
    ((fold
       (lambda (a* r)
         (cond ((null (car a*)) r)
               (t (fold (cdr-of a*)
                        (apply f r (car-of a*))))))))
    (cond ((null a*) (bottom 'too-few-arguments))
          (t (fold a* b)))))

R6RS 还定义了 fold-r [page 271] 的一个变体, 可以处理多个列表. 毫不奇怪, 它被称为 fold-right. 它在多个列表上折叠如下:

(fold-right (lambda (x y z) (list 'op x y z))
            '0
            '(a b c)
            '(d e f))
=> '(op a d (op b e (op c f 0)))

Fold-right 比 fold-left 写起来要棘手一些. 你想在看下面的代码之前试一试吗？

(define (fold-right f b . a*)
  (letrec
    ((foldr
       (lambda (a* r)
         (cond ((null (car a*)) r)
               (t (foldr (cdr-of a*)
                         (apply f (append (car-of a*)
                                          (list r)))))))))
    (cond ((null a*) (bottom 'too-few-arguments))
          (t (foldr (map reverse a*) b)))))

Fold-right 在其一般情况下使用 append. 这是一个问题吗？如果是, 你能做些什么？如果不是, 为什么不？(Q4)

2.1.7. 4.7 替换变量

substitute 函数用给定环境中存储的值替换形式中的变量:

(define env '((x . foo) (y . bar)))
(substitute '(cons x y) env) => '(cons foo bar)

Substitute 的实现相当直接. 你可以在继续阅读之前尝试一下. 提示: 它的代码类似于 replace [page 30].

(define (substitute x env)
  (letrec
    ((value-of
       (lambda (x)
         (let ((v (assq x env)))
           (cond (v (cdr v))
                 (t x)))))
     (subst
       (lambda (x)
         (cond ((null x) ())
               ((atom x) (value-of x))
               (t (cons (subst (car x))
                        (subst (cdr x))))))))
    (subst x)))

如果你从 subst 的 cond 中移除子句 ((null x) ()) 会发生什么？

为什么 substitute 不能用于替换 lambda 形式主体中的变量？提示: 这与 beta 归约有关 [page 59]. (Q5)

2.2. 5. 排序

2.2.1. 5.1 插入排序

insert 函数将一个项目插入到一个有序列表中. 一个有序列表是 $(x_1 x_2 ... x_n)$ 其中一个谓词 p 对每两个连续的成员都成立:

(p xi xi+1) => :t

对于每个 $i$ 在 $1..n-1$ 之间. 给定一个可变参数谓词 p,

(apply p x)

适用于每个在 p 下有序的列表.

这是 insert 的代码:

(define (insert p x a)
  (letrec
    ((ins
       (lambda (a r)
         (cond ((or (null a) (p x (car a)))
                (append (reverse (cons x r)) a))
               (t (ins (cdr a) (cons (car a) r)))))))
    (ins a ())))

一个排好序的列表是通过连续将元素插入一个最初为空的列表来构造的:

(load ~nmath)
(insert < '#5 ()) => '(#5)
(insert < '#1 '(#5)) => '(#1 #5)
(insert < '#7 '(#1 #5)) => '(#1 #5 #7)
(insert < '#3 '(#1 #5 #7)) => '(#1 #3 #5 #7)

注意, 只有非对称谓词 (如 <) 才能对列表施加顺序. 例如, 使用 (对称的) neq 谓词向列表中插入元素并不能对该列表进行排序:

(load ~nmath)
(insert neq '#5 ()) => '(#5)
(insert neq '#1 '(#5)) => '(#1 #5)
(insert neq '#7 '(#1 #5)) => '(#7 #1 #5)
(insert neq '#3 '(#7 #1 #5)) => '(#3 #7 #1 #5)

如果对于每个 a 和 b, (p b a) 都从 (p a b) 推导出来, 那么一个谓词是对称的. 如果这个蕴涵不成立, 那么一个谓词是非对称的. 经常用于对列表进行排序的非对称谓词包括 <, <=, > 和 >=.

isort 函数将多个成员插入一个最初为空的列表中, 从而有效地对这些成员进行排序:

(isort < '(#5 #1 #7 #3)) => '(#1 #3 #5 #7)

这是它的代码:

(require 'insert)
(define (isort p a)
  (Letrec
    ((sort
       (lambda (a r)
         (cond ((null a) r)
               (t (sort (cdr a)
                        (insert p (car a) r)))))))
    (sort a ())))

这个算法被广泛称为插入排序 (insertion sort).

isort 为了对 n 个元素的列表进行排序, 需要应用其谓词 p 多少次, 如果:

元素是按相反顺序排序的;
元素已经排好序;
元素是随机分布的?

上述值差异很大吗？这个结果是否使插入排序成为一种可行的排序算法？(Q6)

2.2.2. 5.2 快速排序

快速排序 (Quicksort) 可能是最高效的算法之一. 它使用分治法 (divide and conquer). 这种方法通过将问题分解成更小的子问题, 解决它们, 然后重新组装结果来工作: ¹⁰

2.2.3. 5.3 归并排序

快速排序和插入排序的性能都取决于传递给它们的数据. 当然, 这对于一个排序算法来说不是一个理想的属性.

归并排序 (Mergesort) 的效率与快速排序大致相同, 而其性能是恒定的. 在没有可变数据的环境 (如 zenlisp) 中, 归并排序甚至比快速排序稍有效率.

这是它的代码:

(define (mergesort p a)
  (letrec
    ((split
       (lambda (a r1 r2)
         (cond ((or (null a)
                    (null (cdr a)))
                (list (reverse r2) r1))
               (t (split (cddr a)
                         (cdr r1)
                         (cons (car r1) r2))))))
     (merge
       (lambda (a b r)
         (cond
           ((null a)
            (cond ((null b) r)
                  (t (merge a (cdr b) (cons (car b) r)))))
           ((null b)
            (merge (cdr a) b (cons (car a) r)))
           ((p (car a) (car b))
            (merge a (cdr b) (cons (car b) r)))
           (t (merge (cdr a) b (cons (car a) r))))))
     (sort
       (lambda (a)
         (cond ((or (null a)
                    (null (cdr a)))
                a)
               (t (let ((p* (split a a ())))
                    (merge (reverse (sort (car p*)))
                           (reverse (sort (cadr p*)))
                           ())))))))
    (sort a)))

归并排序的性能是恒定的, 因为它分割 (splits) 其输入而不是分区 (partitioning) 它. 这就是归并排序内部的 split 函数所做的:

(split '#abcdef '#abcdef ()) => '(#abc #def)

如这个例子所示, 列表只是从中间被简单地分割, 不管它包含哪些成员. 因此, 归并排序总是以最优的方式分割其输入.

你可能会想知道为什么 split 实际上是从中间分割列表. 通过简单地交替地将成员推到另外两个列表来分割列表不是更容易吗？像这样:

(define (naive-split a r1 r2)
  (cond ((null a)
         (list r1 r2))
        ((null (cdr a))
         (list (cons (car a) r1) r2))
        (t (naive-split (cddr a)
                        (cons (car a) r1)
                        (cons (cadr a) r2)))))
(naive-split '#abcdef () ()) => '(#eca #fdb)

虽然这个函数更简单, 甚至可能比 split 更有效率一点, 但它也是错误的. 你能解释为什么吗？

当分割不那么简单的数据时, 答案就变得显而易见了:

(define set '((#5 b) (#1 a) (#5 c) (#7 a) (#9 a) (#3 a)))
(split set set ())
=> '(((#5 b) (#1 a) (#5 c)) ((#7 a) (#9 a) (#3 a)))
(naive-split set () ())
=> '(((#9 a) (#5 c) (#5 b)) ((#3 a) (#7 a) (#1 a)))

上述集合的每个成员都包含一个数字键和一个附加符号. 两个分割函数都均匀地分割了集合, 但 split 保留了成员的顺序, 而 naive-split 交换了一些成员.

虽然两个分割函数在归并排序中都能正常工作, 但朴素的变体将导致一个不稳定的 (unstable) 排序函数. 一个不稳定的排序函数能够很好地对成员进行排序, 但可能会在这个过程中交换具有相同键的成员. 稳定性是排序函数的一个理想属性.

顺便说一句, quicksort 和 mergesort 只有在使用非严格谓词如 <= 和 >= 时才是稳定的. 当传递给它们严格谓词如 < 和 > 时, 它们是不稳定的. Isort 只有在使用严格谓词时才是稳定的.

你认为这两种方法中哪一种更有优势？为什么？(Q7)

你能以这样一种方式修改 isort, 使其在使用非严格谓词时变得稳定吗？(Q8)

你可能已经猜到了: 你能以这样一种方式修改 quicksort 和 mergesort, 使其在使用严格谓词时变得稳定吗？(Q8)

2.2.4. 5.4 打乱列表

在检查排序函数时, 有一些未排序的数据会很好. unsort 函数创建未排序的自然数列表:

(unsort '(#1 #2 #3 #4 #5 #6 #7 #8 #9 #10) '#3)
=> '(#8 #5 #1 #7 #10 #9 #3 #2 #6 #4)

它的输入必须是连续的自然数列表, 但它们不需要以任何特定的顺序出现:

(unsort '(#8 #5 #1 #7 #10 #9 #3 #2 #6 #4) '#5)
=> '(#5 #8 #1 #2 #3 #6 #7 #4 #10 #9)

unsort 的第二个参数是“种子”— 将被取消排序的列表的第一个成员. 它必须是一个小于给定列表长度的自然数.

这是 unsort 的代码:

(require '~nmath)
(require 'nth)

(define (unsort a seed)
  (letrec
    ((remove-nth
       (lambda (a n r)
         (cond ((zero n)
                (cond ((null a) (reverse r))
                      (t (append (cdr a) (reverse r)))))
               (t (remove-nth (cdr a)
                              (- n '#1)
                              (cons (car a) r))))))
     (unsort4
       (lambda (a n k r)
         (cond ((zero k) (cons (car a) r))
               (t (unsort4 (remove-nth a n ())
                           (remainder (car a) k)
                           (- k '#1)
                           (cons (car (nth n a)) r)))))))
    (unsort4 a seed (- (length a) '#1) ())))

与 iota [page 86] 结合使用时, unsort 可用于创建更大的未排序数据集. 此类集合对于检查排序函数的效率非常有用. 以下定义创建了一些测试集:

(define sorted-set (iota '#1 '#100))         ; 1..100
(define reverse-set (reverse sorted-set))    ; 100..1
(define random-set (unsort sorted-set '#99)) ; random order

与 stats 元函数结合使用, 像这样的集合可用于测试排序函数在处理已排序输入、反向排序输入和随机输入时的性能.

图 2 总结了一些结果. 表中的数字表示归约步骤. 每个归约, 如检索变量的值或函数应用, 都算一步.

Table 2: Fig. 2 – run times of sorting algorithms
size	isort sorted	reverse	random	quicksort sorted	reverse	random	mergesort sorted	reverse	random
10	43,764	9,701	29,923	38,014	46,245	30,587	18,705	17,679	22,619
20	174,833	20,422	95,433	158,906	184,724	55,261	46,805	45,262	65,116
30	408,957	32,096	244,376	371,783	430,858	126,311	79,393	82,692	109,486
40	758,136	44,723	346,366	685,945	796,647	169,333	120,065	118,086	170,110
50	1,234,370	58,303	680,393	1,110,692	1,294,091	256,190	168,093	166,374	235,366
60	1,849,659	72,836	984,197	1,655,324	1,935,190	422,885	208,201	219,251	310,940
70	2,616,003	88,322	1,388,878	2,329,141	2,731,944	434,277	269,668	274,136	390,619
80	3,545,402	104,761	1,883,191	3,141,443	3,696,353	621,906	324,707	324,210	477,393
90	4,649,856	122,153	2,516,138	4,101,530	4,840,417	623,504	399,655	394,382	569,448
100	5,896,572	140,126	3,137,972	5,193,349	6,131,343	825,283	457,256	460,812	676,687

对于每种算法, 都给出了对已排序数据、反向排序数据和随机数据进行排序所需的步骤. 事实上, quicksort 在对非随机数据进行排序时表现得非常糟糕, 这是实现的缺陷, 而非算法本身的缺陷.

目前 quicksort 的实现表现得和 isort 一样糟糕, 当对已排序的数据进行排序时, 以及在对反向排序的数据进行排序时同样糟糕, 这可以通过从当前分区 (p*) 中选择一个随机阈值来补救.

然而, Quicksort 算法确实有一个弱点, 这是由它对要排序的数据的依赖性引起的. 已经做了很多研究来打破这种依赖性, 事实上, Quicksort 的高效实现在实践中是最快的排序函数.

Mergesort 比 Quicksort 更容易高效地实现, 因为它的性能不依赖于要排序的数据 ¹¹, 并且在数据不能被改变的纯函数式环境中具有优势.

2.3. 6. 逻辑与组合函数

2.3.1. 6.1 将列表转换为集合

集合 (set) 是一个由唯一成员组成的列表. 例如, '(a b c) 是一个集合, 但 '(a a b) 不是, 因为 'a 在列表中出现了两次. 作为一个手指练习: 你能创建一个尾递归函数, 将列表转换为集合吗？例如:

(list->set '(a a b)) => '(a b)

这是一个可能的解决方案:

(define (list->set a)
  (letrec
    ((l->s
       (lambda (a r)
         (cond ((null a)
                (reverse r))
               ((member (car a) r)
                (l->s (cdr a) r))
               (t (l->s (cdr a) (cons (car a) r)))))))
    (l->s a ())))

2.3.2. 6.2 集合的并集与交集

使用 list->set 计算多个集合的并集非常简单, 几乎不值得为此编写一个函数:

(require 'list-to-set)
(define (union . a)
  (list->set (apply append a)))

集合的交集要棘手一些. 本书前面 [page 24] 已经深入讨论过. 这里是一个使用 fold 的尾递归变体.

当然, 你可以在阅读之前自己尝试编写.

(define (intersection . a)
  (letrec
    ((intersection3 (lambda (a b r)
                      (cond ((null a)
                             (reverse r))
                            ((member (car a) b)
                             (intersection3 (cdr a) b (cons (car a) r)))
                            (t (intersection3 (cdr a) b r))))))
    (fold (lambda (a b)
            (intersection3 a b ()))
          (car a)
          a)))

2.3.3. 6.3 查找具有给定属性的成员

any 函数检查列表是否至少包含一个具有给定属性的成员:

(define (any p a)
(cond ((null a) :f)
      (t (or (p (car a))
             (any p (cdr a))))))
(any atom '(#ab #cd e)) => :t

R6RS 定义了一个 any 的通用版本, 称为 exists. 它与 any 的关系就像 map-car [page 44] 与 map 的关系一样: 它接受任意正数个列表参数和一个要应用的 n 元函数.

以下 exists 的应用会找出在列表 a, b, c 中是否存在任何位置 i, 使得 $b_i$ 是三元组 $(a_i, b_i, c_i)$ 的最小值.

(exists (lambda (ai bi ci)
          (and (< bi ai)
               (< bi ci)))
        a
        b
        c)

再一次, car-of 和 cdr-of 函数 [page 67] 在将固定参数函数转换为可变参数函数时证明很有帮助:

(define (exists p . a*)
  (letrec
    ((exists*
       (lambda (a*)
         (cond ((null (car a*)) :f)
               (t (or (apply p (car-of a*))
                      (exists* (cdr-of a*))))))))
    (exists* a*)))

顺便说一句: exists 不是一个谓词. 你能解释为什么吗？

Exists 可以做比检查是否存在具有给定属性的元组更有趣的事情: 它可以返回那个元组:

(exists (lambda (ai bi ci)
          (and (< bi ai)
               (< bi ci)
               (list ai bi ci)))
        '(#3 #1 #4 #1 #5)
        '(#9 #2 #6 #5 #3)
        '(#5 #8 #9 #7 #9))
=> '(#5 #3 #9)

因为当传递给它一个非谓词时, exists 可能返回一个不同于 :t 或 :f 的值, 所以它本身不是一个谓词.

2.3.4. 6.4 验证属性

你可能已经观察到, exists 函数实现了存在量词 (extistential quantor): 存在一个 x, y, … 使得 (p x y …). R6RS 还描述了一个实现全称量词 (universal quantor) (对于所有 x, y, …) 的函数. 毫不奇怪, 它被称为 for-all, 如果给定的谓词适用于由在相同位置组合列表元素形成的所有元组, 则返回真:

(for-all eq '#abcdef '#abcdef) => :t

当一个非谓词传递给 for-all 时, 它返回可以形成的最后一个元组 (或 :f):

(for-all (lambda (x y)
           (and (eq x y)
                (list x y)))
         '#abcdef
         '#abcdef) => #ff

这是 for-all 的代码:

(define (for-all p . a*)
  (letrec
    ((forall*
       (lambda (a*)
         (cond ((null (car a*)) :t)
               ((null (cdar a*))
                (apply p (car-of a*)))
               (t (and (apply p (car-of a*))
                       (forall* (cdr-of a*))))))))
    (forall* a*)))

当你省略子句时, 函数的行为会以何种方式改变

((null (cdar a*)) (apply p (car-of a*)))

从上面的代码中？(Q10)

当传递空列表时, For-all 返回 :t, 而 exists 在这种情况下返回 :f. 你认为这有道理吗？为什么？

2.3.5. 6.5 集合的组合

本节讨论的函数稍微复杂一些, 所以如果你需要休息一下, 现在是绝佳的时机.

一个源集合 a 的第 n 阶组合 (n-combination) 是一个来自 a 的 n 元素集合. 例如, '#ab 是集合 '#abc 的一个 2-组合. combine 函数从一个给定集合中生成所有可能的无重复的 n 元素组合:

(combine '#2 '#abc) => '(#ab #ac #bc)

Combine* 创建有重复的组合:

(combine* '#2 '#abc) => '(#aa #ab #ac #bb #bc #cc)

因为这些函数的算法非常相似, 它们都在高阶函数 combine3 中实现. 算法的不同部分作为参数传递给 combine3.

n 个元素有重复的组合是这样创建的:

如果 n=0, 组合的集合是空的:

(combine '#0 x) => () ; for any x

如果 n=1,

(combine '#1 x) ----> (map list x) ; for any x

对于 n>1, 组合是递归创建的. 这个过程的第一步是创建源集合所有可能的非空尾部. 这就是 tails-of 函数所做的:

(define (tails-of set)
  (cond ((null set) ())
        (t (cons set (tails-of (cdr set))))))
(tails-of '#abcd) => '(#abcd #bcd #cd #d)

有重复的 N-组合是根据 tails-of 的结果创建的, 如下所示: 每个子列表的头部被附加到同一子列表的所有 n-1 元素组合上. 以下示例概述了 n=2 和 set='#abcd 的过程:

head	tail	1-combinations	result
#a	#abcd	(#a #b #c #d)	(#aa #ab #ac #ad)
#b	#bcd	(#b #c #d)	(#bb #bc #bd)
#c	#cd	(#c #d)	(#cc #cd)
#d	#d	(#d)	(#dd)

结果列的连接是 '#abcd 的所有 2-组合的集合:

'(#aa #ab #ac #ad #bb #bc #bd #cc #cd #dd)

在上面的例子中, combine 以 n=1 调用自身, 所以这个应用由一个平凡情况处理. 当生成更高阶的组合时, 情况如下 (这个例子创建了 '#abcd 的 3-组合):

head	tail	2-combinations	result
#a	#abcd	(#aa #ab #ac #ad #bb #bc #bd #cc #cd #dd)	(#abc #abd #acc #acd #add #aaa #aab…)
#b	#bcd	(#bb #bc #bd #cc #cd #dd)	(#bbb #bbc #bbd #bcc #bcd #bdd)
#c	#cd	(#cc #cd #dd)	(#ccc #ccd #cdd)
#d	#d	(#dd)	(#ddd)

附加到每个尾部集合头部的 2-组合是以与前一个例子相同的方式创建的. 因为 n 递减, 所以最终会达到平凡情况.

下面是创建有重复组合的 combine2 函数的代码:

(require '~nmath)
(define (combine2 n set)
  (cond
    ((zero n) ())
    ((one n) (map list set))
    (t (apply
         append
         (map (lambda (tail)
                (map (lambda (sub)
                       (cons (car tail) sub))
                     (combine2 (- n '#1) tail)))
              (tails-of set))))))

函数的一般情况包含两个嵌套的 map, 它们递归地创建组合. 传递给外部 map 的列表是当前源集合的尾部集合. 内部 map 递归创建较低阶的组合, 然后将这些组合附加到尾部的头部. 最后, 应用 append 将外部 map 的结果扁平化.

无重复的组合基本上与有重复的组合以相同的方式创建. 唯一的区别是, 源集合中的项不能被重用, 所以在创建较低阶的组合之前, 必须将它们从集合中移除. 它是这样工作的:

head	tail	1-combinations	result
#a	#bcd	(#b #c #d)	(#ab #ac #ad)
#b	#cd	(#c #d)	(#bc #bd)
#c	#d	(#d)	(#cd)

所以, 在递归时, 应该只将整个集合的 cdr 部分传递给 combine2. 这个修改非常简单, 以至于执行 cdr 操作的函数作为附加参数传递给 combine3. 与 combine2 的差异以粗体字符显示:

(define (combine3 n set rest)
  (lambda (n set)
    (cond
      ((zero n) ())
      ((one n) (map list set))
      (t (apply
           append
           (map (lambda (tail)
                  (map (lambda (sub)
                         (cons (car tail) sub))
                       (combine3 (- n '#1) (rest tail) rest)))
                (tails-of set)))))))

当 rest=cdr 传递给 combine3 时, 它计算无重复的组合. 为了计算有重复的组合, 传递给它的是恒等函数 id ¹² . 所以 combine 和 combine* 可以定义如下:

2.3.6. 6.6 集合的排列

排列 (permutation) 与组合 (combination) 的不同之处在于, 顺序在组合中不重要, 但在排列中很重要. 因此, 序列 '#ab 和 '#ba 表示相同的组合, 但表示不同的排列. '#ab 和 '#ba 都将 a 和 b 组合在一起, 但 '#ab 是 '#ba 的一个排列 (在这种情况下是唯一的).

像组合一样, 排列可以有重复也可以没有重复. 本节介绍的 permute 和 permute* 函数创建了有重复和无重复的集合的所有可能排列:

(permute '#2 '#abc) => '(#ab #ba #ac #ca #bc #cb)
(permute* '#2 '#abc) => '(#aa #ab #ac #ba #bb #bc #ca #cb #cc)

我们将从一个函数开始, 该函数从大小为 n 的源集合创建无重复的 n-排列, 例如:

(permutations '#abc) => '(#abc #acb #bca #bac #cab #cba)

这个函数的平凡情况很简单. 0-排列是空的:

(permutations ()) => ()

而 1-排列等于一个包含源集合的集合:

(permutations '(x)) ----> (list '(x)) ; for any atom x

排列的创建方式与组合几乎相同, 但因为顺序在排列中很重要, 所以源集合的每个元素都必须占据每个位置一次. 这可以通过旋转集合的成员来轻松实现:

'#abcd
'#bcda
'#cdab
'#dabc

rotate 函数将集合旋转一个位置:

(define (rotate x)
  (append (cdr x) (list (car x))))

使用 rotate, 创建所有旋转很容易:

(define (rotations x)
(letrec
  ((rot (lambda (x n)
          (cond ((null n) ())
                (t (cons x (rot (rotate x)
                                (cdr n))))))))
  (rot x x)))

(rotations '#abcd) => '(#abcd #bcda #cdab #dabc)

permutations 函数本身看起来很像 combine3 [page 83]. 它只是有不同的平凡情况, 并且使用 rotations 代替 tails-of:

(define (permutations set)
(cond
  ((null set) ())
  ((null (cdr set)) (list set))
  (t (apply append
       (map (lambda (rotn)
              (map (lambda (x)
                     (cons (car rotn) x))
                   (permutations (cdr rotn))))
            (rotations set))))))

虽然这个函数工作得很好, 但它只能创建其阶数等于源集合大小的排列. 较低阶的排列可以通过首先创建相同阶的组合, 然后对结果进行排列和附加来计算:

(combine '#2 '#abc) => '(#ab #ac #bc)
(map permutations '(#ab #ac #bc)) => '((#ab #ba) (#ac #ca) (#bc #cb))
(apply append '((#ab #ba) (#ac #ca) (#bc #cb)))
 => '(#ab #ba #ac #ca #bc #cb)

这正是以下 permute 的实现所做的:

(require 'combine)

(define (permute n set)
  (apply append (map permutations (combine n set))))

有重复的排列的创建方式与有重复的组合类似 (见 combine2, 第 82 页). 唯一的区别是, 整个源集合在每个 map 中都被传递:

(define (permute* n set)
  (cond
    ((zero n) ())
    ((one n) (map list set))
    (t (apply append
         (map (lambda (x)
                (map (lambda (sub)
                       (cons x sub))
                     (permute* (- n '#1) set)))
              set)))))

permutations 函数的复杂度是多少？

2-元素集合的 2-排列等于该集合的旋转:

(permutations '#xy) => '(#xy #yx)
  (rotations '#xy) => '(#xy #yx)

所以我们可以向 permutations 函数添加第三个平凡情况:

((null (cddr set)) (rotations set))

你会把这个情况插入到哪里？这个修改有意义吗？它会改善 permutations 的运行时间吗？它会改变其复杂度吗？(Q12)

2.4. 7. 数学函数

2.4.1. 7.1 数字序列

iota 函数创建整数序列:

(iota '#1 '#10) => '(#1 #2 #3 #4 #5 #6 #7 #8 #9 #10)
(iota '#-3 '#-1) => '(#-3 #-2 #-1)

与 map 结合使用, 它可以创建各种序列:

(map (lambda (x) (* x x))
     (iota '#1 '#5))
=> '(#1 #4 #9 #16 #25)
(require '~combine)
(map (lambda (x) (combine x '#abcde))
     (iota '#0 '#5))
=> '(()
     (#a #b #c #d #e)
     (#ab #ac #ad #ae #bc #bd #be #cd #ce #de)
     (#abc #abd #abe #acd #ace #ade #bcd #bce #bde #cde)
     (#abcd #abce #abde #acde #bcde)
     (#abcde))
(map (lambda (x) (length (combine* x '#abcd)))
     (iota '#1 '#10))
=> '(#4 #10 #20 #35 #56 #84 #120 #165 #220 #286)

iota 的实现比它的许多应用简单得多:

(require '~imath)
(define (iota lo hi)
  (letrec
    ((j (lambda (x r)
          (cond ((< x lo) r)
                (t (j (- x '#1) (cons x r)))))))
    (j (integer hi) ())))

你能用 iota 来估计像 combine*, permute*, unsort 或 iota 本身这样一些函数的复杂度吗？

2.4.2. 7.2 快速阶乘函数

阶乘函数计算 n! (“n 阶乘”), 或

(* 1 2 ... n)

然而, 它使用的算法比仅仅按顺序乘以数字更有效率. 它可以在合理的时间内计算像 100! 这样的值, 即使在像 zenlisp 这样的纯符号系统上. 该算法被称为递归乘积 (recursive product).

代码紧随其后. 你能看出为什么它比朴素的方法更有效率吗？

(require '~nmath)
(define (factorial n)
  (letrec
    ((r* (lambda (n m)
           (cond ((< m '#2) n)
                 (t (let ((q (quotient m '#2)))
                      (* (r* n q)
                         (r* (+ n q) (- m q)))))))))
    (r* '#1 (natural n))))

阶乘函数是肥递归的 (fat recursive): 它的复杂度与结构递归函数相同, 尽管它不处理递归结构. 这通常被认为是一个坏主意, 但在这种特殊情况下, 它实际上改善了函数的运行时间.

Factorial 使用分治法 [见 page 70]. 给定值 n, 它首先计算 1..n/2 和 n/2+1..n 的乘积, 然后将它们相乘. 它使用的乘法次数与“朴素”函数相同 (实际上少一次), 但它避免了尽可能长时间地乘以大数, 正如在下表中可以看到的:

naive approach	recursive product
(f '#10)	(factorial '#10)
+ (* #1 #1)	+ (* #1 #2)
+ (* #2 #1)	+ (* #4 #5)
+ (* #3 #2)	+ (* #3 #20)
+ (* #4 #6)	+ (* #2 #60)
+ (* #5 #24)	+ (* #6 #7)
+ (* #6 #120)	+ (* #9 #10)
+ (* #7 #720)	+ (* #8 #90)
+ (* #8 #5040)	+ (* #42 #720)
+ (* #9 #40320)	+ (* #120 #30240)
+ (* #10 #362880)

输出是在计算 10! 时跟踪 * 创建的. ¹³

在 zenlisp 中有一种更简单 (且有趣的是更有效) 的方法来计算 n!. 这种方法根本不使用递归. 提示: 它确实使用了本节中的一个函数. (Q13)

2.4.3. 7.3 整数分解

factors 函数计算一个给定整数的组成质因数:

(factors '#123456789) => '((#3803 #1) (#3607 #1) (#3 #2))

它返回一个由两个元素组成的列表的列表, 其中每个子列表应读作 $car^{cadr}$, 所以上面的整数分解为 \[ 3383^1 \times 3607^1 \times 3^2 = 3383 \times 3607 \times 3 \times 3 \] 在计算素数、互质数或由相当大的因数组成的整数 (如上) 的因数时, Factors 可能需要一些时间才能完成. 它实际上尝试用 $\{2,3,5,...,\sqrt{n}\}$ 来除给定的数 n, 并记住找到的商:

(require '~nmath)
(define (factors n)
  (letrec
    ((quotient+exponent
       (lambda (n m)
         (letrec
           ((div (lambda (n m r)
                   (let ((qr (divide n m)))
                     (cond ((zero (cadr qr))
                            (div (car qr) m (+ '#1 r)))
                           (t (cons n r)))))))
           (div n m '#0))))
     (add-expt
       (lambda (b e r)
         (cond ((zero e) r)
               (t (cons (list b e) r)))))
     (factorize
       (lambda (n d r)
         (let ((lim (sqrt n)))
           (letrec
             ((factorize3
                (lambda (n d r)
                  (let ((rest/exp (quotient+exponent n d)))
                    (let ((q (car rest/exp))
                          (e (cdr rest/exp)))
                      (cond
                        ((< q '#2) (add-expt d e r))
                        ((> d lim) (add-expt n '#1 r))
                        (t (factorize3
                             q
                             (cond ((= d '#2) '#3)
                                   (t (+ d '#2)))
                             (add-expt d e r)))))))))
             (factorize3 n d r))))))
    (cond
      ((< n '#1) (bottom 'operand-not-positive n))
      ((= n '#1) '#1)
      (t (factorize n '#2 ())))))

该函数非常直接. 它的辅助函数 quotient+exponent 返回当 n 被 m 除给定次数后剩下的商. 除法的次数作为“指数”部分返回. 例如:

(quotient+exponent '#24 '#2) => '(#3 . #3)

24 可以被 2 除三次, 所以 3 作为结果的 cdr 部分返回. $24/2^3=3$, 所以 3 也作为商在 car 部分返回.

(quotient+exponent '#24 '#3) => '(#8 . #1)

24 可以被 3 除一次, 留下商 8.

(quotient+exponent '#24 '#9) => '(#24 . #0)

24 完全不能被 9 整除 (零次, 留下“商”24).

Add-expt 仅在指数非零时向结果添加一个因数.

Factorize 计算 $\sqrt{n}$ 的限制, 然后遍历可能的除数列表.

你能想象为什么选择要分解的整数的平方根作为上限吗？

似乎没有一个真正有效的算法来分解大整数. 如果有的话, 基于计算机的密码学很可能会成为一门失传的艺术. 不过, 这并不意味着要阻止你寻找更好的算法.

2.4.4. 7.4 整数分区

一个整数 n 的 (数论) 分区 (partition) 是一个加起来等于 n 的整数和. 例如, 这些是 4 的分区:

4   3+1   2+2   2+1+1   1+1+1+1

创建分区类似于创建排列. 唯一的区别是分区的元素可以被分成两部分, 例如 3 可以被分成 2 和 1, 2 可以被分成 1 和 1.

以下代码基于 permutations [page 84]. 它不是将集合的头部附加到其其余部分的每个排列上, 而是将区间 1..n 的每个值 i 附加到 n-i 的分区上, 例如: 对于 n=4

1 被附加到 3 的分区上;
2 被附加到 2 的分区上;
3 被附加到 1 的分区上;
4 被附加到 0 的分区上.

平凡情况处理零 (给出空分区) 和一 (给出一的分区) 的值. 分区被表示为列表, 所以 4 的分区将写成

'((#4) (#3 #1) (#2 #2) (#2 #1 #1) (#1 #1 #1 #1)).

这是代码 (但在继续阅读之前, 请随意尝试自己开发):

(require '~nmath)
(require 'iota)

(define (part n)
  (cond
    ((zero n) '(()))
    ((one n) '((#1)))
    (t (apply append
         (map (lambda (x)
                (map (lambda (p) (cons x p))
                     (part (- n x))))
              (iota '#1 n))))))

让我们看看它的表现如何:

(part '#4)
=> '((#1 #1 #1 #1) (#1 #1 #2) (#1 #2 #1) (#1 #3) (#2 #1 #1) (#2 #2) (#3 #1) (#4))

看起来不错, 除了列表是倒序的 (这很容易修复), 并且它包含一些重复项 (以粗体字符显示). 所以也许我们需要一个基于组合而不是排列的解决方案？在我们深入探讨这个想法之前: 关于上面的结果有什么明显的吗？

嗯？

完全正确: 所有不重复的分区都按降序排列 (但不是严格降序), 所以我们可以过滤它们. 这就是 make-partitions 函数所做的:

(define (make-partitions n)
  (letrec
    ((filter-descending
       (lambda (p)
         (cond ((null (cdr p)) p)
               ((apply >= (car p))
                (cons (car p) (filter-descending (cdr p))))
               (t (filter-descending (cdr p)))))))
    (reverse (filter-descending (part n)))))

确实:

(make-partitions '#4) => '((#4) (#3 #1) (#2 #2) (#2 #1 #1) (#1 #1 #1 #1))

为什么我们不使用 filter [page 42] 来过滤结果？(Q14)

给出一个 100 的分区的合理上限. 为什么 make-partitions 在这个过程中不是一个很好的帮助？

2.4.5. 7.5 探索可计算性的极限

看一下下面的函数:

(define (s x) (+ '#1 x))

s 函数很像 succ [page 276], 但它递增的是整个自然数, 而不仅仅是单个数字:

(s '#0) => '#1
(s (s '#0)) => '#2
(s (s (s '#0))) => '#3

使用这个函数, 两个数 a 和 b 的加法可以定义为 s 对 a 的 b 次应用: \[ a+b := \underbrace{(s \dots (s a)) \dots}_{b \text{ times}} \] 同样地, a 和 b 的乘法可以表示为“加”运算符的 b 次应用, a 的 b 次方可以表示为乘法的 b 次应用: \[ a*b := \underbrace{a+\dots + a}_{b \text{ times}} \qquad a^b := \underbrace{a*\dots * a}_{b \text{ times}} \] 游戏并未就此结束. 幂运算符对 a 的 b 次应用被称为高度为 b 的幂塔 (power tower): \[ a^{\hat{\,}\hat{\,}}b := \underbrace{a^{a^{\cdot^{\cdot^a}}}}}_{b \text{ times}} \] 幂塔的典型表示法是 $a^{\hat{\,}\hat{\,}}b$ 和 $a^{(4)}b$. 前者读作“power power”, 后者读作“hyper-4”. 超运算符 (hyper operator) 实际上是上述所有运算的推广:

hyper notation	equivalent form
$a^{(0)}b$	(s a) for any value of b
$a^{(1)}b$	a + b
$a^{(2)}b$	a * b
$a^{(3)}b$	$a^b$
$a^{(4)}b$	$a^{\hat{\,}\hat{\,}}b$

再一次, 函数的实现看起来比它的含义要无辜得多:

(require '~nmath)
(define (hyper n a b)
  (cond ((equal n '#0) (+ '#1 a))
        ((equal n '#1) (+ a b))
        ((one b) a)
        ((equal n '#2) (* a b))
        ((equal n '#3) (expt a b))
        ((equal n '#4) (expt a (hyper n a (- b '#1))))
        ((> n '#4) (hyper (- n '#1) a (hyper n a (- b '#1))))))

既然我们已经知道有一个 hyper-4 运算符, 为什么不应该有一个 hyper-5 运算符, 一个幂塔的塔？或者一个 hyper-6 运算符, 或者, 话说回来, 一个 hyper-100 运算符？

我们将会看到.

有一件事是肯定的: 无论 hyper 的哪个参数增加, 只要 n 至少是 4, 它的值就会增长得非常快:

(hyper '#4 '#1 '#3) = 1^^1 = 1^1 = 1                      (1 digit)
(hyper '#4 '#2 '#3) = 2^^2 = 2^2 = 2                      (1 digit)
(hyper '#4 '#3 '#3) = 3^^3 = 3^3^3 = 3^27 = 7625597484987 (13 digits)
(hyper '#4 '#4 '#3) = 4^^3 = 4^4^4 = 4^256 = ...          (155 digits)
(hyper '#4 '#5 '#3) = 5^^3 = 5^5^5 = 5^3125 = ...        (2185 digits)
(hyper '#4 '#6 '#3) = 6^^3 = 6^6^6 = 6^46656 = ...        (36306 digits)

迭代 hyper 的第一个因子会导致惊人的增长. 即使是 $4^{(4)}3$ (或 (hyper '#4 '#4 '#3)) 的结果也远大于已知宇宙中的原子数量 (大约是 $10^{80}$).

但这仅仅是个开始. 正如我们在关于函数复杂度的部分 [page 75] 中看到的, 迭代指数比迭代幂的底数产生更快的增长. 所以:

(hyper '#4 '#3 '#1) = 3
(hyper '#4 '#3 '#2) = 3^3 = 27
(hyper '#4 '#3 '#3) = 3^^3 = 3^3^3 = 3^27 = 7625597484987
(hyper '#4 '#3 '#4) = 3^^4 = 3^3^3^3 = 3^3^27 = 3^7625597484987
(hyper '#4 '#3 '#5) = 3^^5 = 3^3^3^3^3 = 3^3^3^27 = 3^3^7625597484987

$3^{(4)}4 = 3^{7625597484987}$ 是一个大约有 3,638,334,640,024 位的数字. 那是 3.6 万亿位. 如果你用很小的字体打印这个数字, 在一页上挤下 100,000 位, 你仍然需要 3600 万页. 而 $3^{(4)}5$ 是 3 的那个数的幂.

但即使是这种增长, 与迭代 hyper 运算符的阶数相比也显得微不足道:

(hyper '#1 '#3 '#3) = 3+3 = 6
(hyper '#2 '#3 '#3) = 3*3 = 9
(hyper '#3 '#3 '#3) = 3^3 = 27
(hyper '#4 '#3 '#3) = 3^^3 = 3^3^3 = 3^27 = 7625597484987
(hyper '#5 '#3 '#3) = 3^^^3 = 3^^3^^3 = 3^^7625597484987

$3^{(5)}3$ 是一个高度为 7,625,597,484,987 的幂塔. 这是一个 7.6 万亿层的塔: \[ \left. \begin{matrix} 3 \\ \cdot^{\cdot^{\cdot^3}} \end{matrix} \right\} \text{7,625,597,484,987 times} \] 这样的数字远远超出了人类的理解范围, 一个结果与下一个结果之间的差异呈指数级增长. 这就是为什么这种增长被称为超指数 (hyper-exponential) 增长.

你认为具有超指数复杂度的函数在实践中会有任何用途吗？

将 $3^{(6)}3$ 尽可能地归约为低阶运算. 尝试描述 $3^{(6)}3$ 的大小. (Q15)

找出你的计算机最终会返回一个值的所有 hyper 参数集. 仅仅尝试显然不是一个选项, 所以你需要做一些脑力工作, 但这正是计算科学的意义所在.

你认为购买一台更快的计算机和更多内存会扩展上述集合吗？

$2^{(100)}2$ 的值是多少？… … … … … … … … … … 是的, 这是一个陷阱问题.

2.4.6. 7.6 矩阵转置

本章以一个有用的小巧单行代码结束, 它能转置一个矩阵. 矩阵以行的列表形式存储. 该函数交换列和行:

(transpose '(#abc #def)) => '(#ad #be #cf)
(transpose '(#ad #be #cf)) => '(#abc #def)

这是代码:

(define (transpose x) (apply map list x))

你能解释它是如何工作的吗？

2.5. 8. 数据结构

2.5.1. 8.1 生成器

生成器 (generator) 是一种能生成一系列值的数据结构. 然而, 生成器的概念似乎暗示了某种可变状态, 正如下面的例子通过一个创建自然数的生成器所说明的那样:

(g) => '#1
(g) => '#2
(g) => '#3
...

每次调用 g 时, 它都会返回一个不同的值, 所以 g 在严格意义上不能是一个函数. 然而, 在 zenlisp 中, 有可能以纯函数的方式实现生成器. 它是这样工作的:

(define (generator start step)
  (lambda ()
    (cons start
          (generator (step start) step))))

(define (value g) (car g))
(define (next g) ((cdr g)))

generator 函数是一个返回生成器的高阶函数. 当被调用时, 生成器提供一个由初始值 start 和另一个携带 (step start) 作为其值的生成器组成的数据结构.

该结构是无限递归的, 但却是有限的. 这是因为在请求之前不会归约任何生成器. 因此, 生成器也被称为惰性结构 (lazy structure). 这是生成器的实际应用:

(load ~nmath)
(generator '#1 (lambda (x) (+ '#1 x)))
 => {closure ()}
 (**) => '(#1 . (closure ()))
(next **) => '(#2 . (closure ()))
(next **) => '(#3 . (closure ()))
...

* 运算符总是包含最近的顶层结果, 所以 (next *) 会拾取前一个结果并运行其内嵌的生成器. 当然, ** 本身是有状态的, 并且只在交互式计算中有效, 所以这里是同一个没有它的例子:

(let ((g ((generator '#1 (lambda (x) (+ '#1 x))))))
  (let ((x (value g))
        (g (next g)))
    (let ((y (value g))
          (g (next g)))
      (let ((z (value g))
            (g (next g)))
        (list x y z)))))
=> '(#1 #2 #3)

(next g) 形式的每次应用似乎都有副作用, 因为它提供了一个新值, 但它实际上所做的是将当前生成器映射到一个新的生成器, 所以它实际上是一个普通函数.

这是“幕后”发生的事情:

(define (inc x) (+ '#1 x))
(generator '#1 inc)
 => (lambda () (cons '#1 (generator (inc '#1) inc)))
 (**) => '(#1 . (lambda () (cons '#2 (generator (inc '#2) inc))))
(next **) => '(#2 . (lambda () (cons '#3 (generator (inc '#3) inc))))
(next **) => '(#3 . (lambda () (cons '#4 (generator (inc '#4) inc))))

你能创建一个产生列表尾部的生成器吗？当到达列表末尾时会发生什么？你能以更优雅的方式处理这种情况来改进 generator 函数吗？(Q16)

生成器与列表有什么关系？它们的区别是什么, 共同点又是什么？

2.5.2. 8.2 流

基本上, 流 (streams) 是经过改进的生成器. 这是实现 stream 数据类型的 stream 函数的实现:

(define (stream v first filter rest lim final)
  (letrec
    ((find
       (lambda (x)
         (cond ((lim x) x)
               ((filter (first x)) x)
               (t (find (rest x))))))
     (make-stream
       (lambda (v)
         (lambda ()
           (let ((nf (find v)))
             (cond ((lim nf) final)
                   (t (cons (first nf)
                            (make-stream (rest nf))))))))))
    ((make-stream v))))

stream 的 v 变量与 generator [page 94] 的 start 变量功能相同, rest 等同于 step. make-stream 子函数基本等同于 generator, 但增加了一些特性.

使用 stream 可以这样创建一个产生自然数的生成器:

(stream '#1
        id
        (lambda (x) :t)
        (lambda (x) (+ '#1 x))
        (lambda (x) :f)
        :f)

first 变量绑定到一个在返回流的每个值之前对其进行预处理的函数. 因为在这个例子中不需要做什么, 所以传递给 stream 的是恒等函数.

filter 变量绑定到一个谓词, 对于要生成的流的每个成员, 该谓词必须归约为真. 上面的过滤器只是通过所有成员.

Lim 绑定到一个检查流是否结束的谓词. 上面的谓词返回常量假, 所以流是 (潜在地) 无限的. 当 (lim x) 对某个 x 返回真时, 将返回 final 的值.

返回常量真和假的谓词在流中很常见, 所以它们定义如下:

(define (all x) :t)
(define (none x) :f)

next 和 value 函数与 generator 代码中的相同:

(define (value s) (car s))
(define (next s) ((cdr s)))

使用这些缩写, 上面的自然数流可以以一种更易于理解的方式创建:

(stream '#1 id all (lambda (x) (+ '#1 x)) none :f)

这个定义返回一个“从 1 开始, 返回所有成员的恒等, 成员加一, 并且没有限制”的流. 在这种情况下,“final”值无关紧要, 因为限制是 none.

注意 (与 generator 不同) stream 函数立即返回流, 而不是返回流的函数:

(stream '#1 id all (lambda (x) (+ '#1 x)) none :f)
 => '(#1 . {closure ()})
(next **) => '(#2 . {closure ()})
(next **) => '(#3 . {closure ()})
...

一个提供列表成员的流可以这样创建:

(stream '#abc car all cdr null :f)
 => '(a . {closure ()})
(next **) => '(b . {closure ()})
(next **) => '(c . {closure ()})
(next **) => :f

事实上, 这个表达式非常有用, 我们将给它一个名字:

(define (list->stream v)
  (stream v car all cdr null :f))

Stream->list 是 list->stream 的反向操作. 它收集一个流的成员并将它们放入一个列表中.

(define (stream->list s)
  (letrec
    ((s->l
       (lambda (s lst)
         (cond (s (s->l (next s)
                        (cons (value s) lst)))
               (t (reverse lst))))))
    (s->l s ())))

顺便说一句, 为什么将一个自然数流 — 比如上面定义的那个 — 转换成列表不是一个好主意？

下面是一些可以应用于流的高阶函数. 这些函数大多在列表域中有精确的对应物.

stream-member 函数在给定的流中定位第一个满足谓词 p 的成员. 当没有找到这样的成员时, 将返回默认值 d.

(define s (list->stream '(#a b #c d)))
(stream-member atom s :f) => '(b . {closure ()})
(stream-member null s :f) => :f

这是 stream-member 的代码. 注意它同时使用 d 来检测流的结束和指示流的结束:

(define (stream-member p s d)
  (cond ((eq s d) d)
        ((p (value s)) s)
        (t (stream-member p (next s) d))))

pass 函数是另一个方便函数. 它用于指示当嵌入的流返回 :f 时, 应认为该流已耗尽. 然而, 这仅仅是这里使用的一个约定. 任何其他值都可以用来指示流的结束.

(define pass not)

Map-stream 像 map, 但作用于流:

(require ~nmath)
(map-stream (lambda (x) (* x x))
            (stream '#1 id all (lambda (x) (+ '#1 x)) none :f))
 => '(#1 . {closure ()})
(next **) => '(#4 . {closure ()})
(next **) => '(#9 . {closure ()})
(next **) => '(#16 . {closure ()})
...

map-stream 函数可以通过单次调用 stream 来实现:

(define (map-stream f s)
  (stream s (lambda (s) (f (value s))) all next pass :f))

它创建的流“从 s 的值开始, 返回应用于所有成员的 f, 从原始流中获取下一个成员, 将流结束检测传递给原始流, 并返回 :f 作为其最终值.”

所以 map-stream 基本上构建了一个“围绕流的流”. 外部流从内部流中获取值, 并在返回之前对每个值应用一个函数. 在上面的例子中, 内部流仍然创建自然数, 而外部流 — 由 map-stream 创建 — 生成平方数.

filter-stream 函数对流应用一个过滤器, 以便只生成具有特定属性的成员. 它可以被认为是某种“内部 stream-member”函数. 事实上, 它是由 stream 的 find 函数在内部实现的. 同样, 代码是微不足道的:

(define (filter-stream p s)
  (stream s value p next pass :f))

这是它的工作原理:

(filter-stream atom (list->stream '(a #b c #d e)))
 => '(a . {closure ()})
(next **) => '(c . {closure ()})
(next **) => '(e . {closure ()})
(next **) => :f

当然, 流函数可以组合使用:

(require ~nmath)
(map-stream (lambda (x) (* x x))
            (stream '#1 id all (lambda (x) (+ '#1 x)) none :f))
 => '(#1 . {closure ()})
(next **) => '(#4 . {closure ()})
(filter-stream even **)
 => '(#4 . {closure ()})
 => '(#16 . {closure ()})
(next **) => '(#36 . {closure ()})
(filter-stream (lambda (x) (zero (remainder x '#7))) **)
 => '(#196 . {closure ()})
(next **) => '(#784 . {closure ()})
(next **) => '(#1764 . {closure ()})
...

在这个例子中, map-stream 再次创建了一个平方数流. 然后 filter-stream 从该流中过滤出所有偶数. 最后, 另一个过滤器从结果流中提取所有可被 7 整除的数字. 所以最终的流生成了可被 7 整除的偶数平方数. 这里介绍的最后一个函数通过将第一个流包装在第二个流周围来附加两个流. 当第一个流耗尽时, 它返回第二个流作为其最终值:

(define (append-streams s1 s2)
  (stream s1 value all next pass s2))

这是 append-streams 的实际应用:

(stream->list
  (append-streams (list->stream '#hello-)
                  (list->stream '#world!)))
=> '#hello-world!

你能写一个 append-streams* 函数吗, 它像 append-streams, 但附加可变数量的流？(append-streams*) 应该归约为多少？(Q17)

一些流函数可以安全地应用于无限流, 而一些则不能. Stream->list 是一个只接受有限流的函数:

(stream->list (stream 'foo id all id none :f)) => bottom

上面介绍的哪些函数对于无限流是安全的？(Q18)

自己发明一些流函数. 是否有任何列表操作不能用流来表示？

2.5.3. 8.3 ml 风格的记录

记录 (record) 是一组有序的元组, 类似于关联列表. 记录和 alist 之间的区别在于, 记录有固定数量的成员. 添加或删除成员会改变记录的类型. 以下结构类似于记录:

((food ginger) (type root) (vegetarian :t))

记录的每个子列表称为一个字段 (field). 每个字段的 car 部分包含该字段的标签 (tag), 其 cadr 部分包含与该标签关联的值.

ML 语言 ¹⁴ 提供了一种高度灵活的机制来创建和操作记录, 下面的代码将在动态类型、纯函数式环境中尽可能地模拟这一点.

记录使用数字, 因此必须加载任何一个数学包. 如果之前没有加载任何一个, 默认加载 rmath. 这个解决方案允许在任何数学包的组合中使用记录:

2.6. 9. 编译器

2.6.1. 9.1 中缀到前缀的翻译

本节介绍的 infix->prefix 函数实现了一个所谓的递归下降解析器 (recursive descent parser). 解析器是一个分析其输入的句法结构并将其转换为某种其他表示的程序. 在本节介绍的例子中,“其他表示”是 zenlisp 表达式的表示. 递归下降是一种解析技术. 本节将详细解释.

设计解析器时的第一个问题是如何表示其输入. 在现实世界中, 这很可能是一个字符串或一个“文本文件”, 但因为 zenlisp 两者都不提供, 所以将使用列表. 例如, 公式 $x^2 + y$ 将被写成

'#x^2+y

infix->prefix 程序将分析上述形式的公式, 并将它们翻译成相应的 zenlisp 形式, 例如:

(infix->prefix '#x^2+y) => '(+ (expt x '#2) y)
(infix->prefix '#x*2+y*3) => '(+ (* x '#2) (* y '#3))
(infix->prefix '#x*[2+y]*3) => '(* (* x (+ '#2 y)) '#3)

解析器将识别其输入中的以下符号:

Input	Meaning
[a-z]	symbol (single letters only)
[0-9]+	integer numbers (sequences of digits)
+	addition
-	subtraction or negation (depends on context)
*	multiplication
^	exponentation
[]	grouping of subexpressions

然而, 为了详细描述解析器的输入, 需要稍微离题一下.

9.1.1 形式文法
从技术上讲, infix->prefix 程序的输入将是一种形式语言 (formal language). 上一节末尾给出的符号是该语言的词素 (lexemes). 任何这些词素的非空序列都是该语言的句子 (sentence) (尽管不一定是格式良好的). 以下序列是句子:
```
aaaa
a+b
a+-b^
[x]y
]]]
```
就像自然语言一样, 形式语言也有用于构造格式良好的句子的语法. 形式语言的格式良好的句子也称为该语言的程序 (program). 直觉可能会告诉你, 以下句子是程序:
```
a+b
x*y+z
x-17
```
但这些呢:
```
xyz
a--b
p[q]
```
直觉很好, 但在解析器中很难实现, 所以我们需要一些形式化地描述语法的方法. 这就是 BNF (“巴科斯范式”或“巴科斯-瑙尔范式”) 发挥作用的地方. BNF 是一种用于形式化描述编程语言语法的表示法. BNF 描述的基本构件是产生式 (production). 产生式看起来像这样:
```
<sum> := symbol '+' symbol
       | symbol '-' symbol
```
“:=” 运算符读作“定义为”或“可以写成”. “|” 表示逻辑或. 所以上面的产生式说: “一个 <sum> 可以写成一个符号后跟 + 和另一个符号, 或者一个符号后跟 ‘-’ 和另一个符号”.

每个独立出现的名称表示一个词素, 在编译器术语中也称为终结符号 (terminal symbol). 像 symbol 这样的名称通常表示一类符号. 在我们即将定义的语言中, symbol 将表示包含词素的类
```
a b c d e f g h i j k l m n o p q r s t u v w x y z
```
而 number 将表示包含词素的 (无限) 类
```
0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 ...
```
用撇号括起来的名称是表示其自身的终结符号, 所以 '+' 表示词素 +, '[' 表示词素 [.

用尖括号括起来的名称, 如 <sum>, 是所谓的非终结符号 (non-terminal symbols). 它们表示产生式. 用于终结符、非终结符甚至运算符的约定在不同教科书之间有所不同, 但基本原则总是一样的: 产生式的左侧给产生式一个名称, 右侧描述了左侧可以被什么替换. 例如, 根据上面的产生式, 这些是 <sum> (这里的通用箭头表示“根据规则”):
```
a+b ----> symbol '+' symbol
x-y ----> symbol '-' symbol
```
任何不匹配 <sum> 规则的句子都不是 <sum> 的有效程序. 术语规则 (rule) 有时用作“产生式”的同义词. 不过, 在本文中,“规则”将用于指代产生式的一个备选项, 所以 <sum> 产生式有两个规则. 这些规则也可以写成单独的产生式:
```
<sum> := symbol '+' symbol
<sum> := symbol '-' symbol
```
不过, 这很少这样做, 因为“或”运算符使产生式更具可读性.

无处不在的递归原则在 BNF 产生式中也扮演着核心角色. 它用于描述可变长度的句子:
```
<a*> := 'a'
      | 'a' <a*>
```
产生式 <a*> 匹配任意正数个 a. 它的规则说 <a*> 可以被一个 a 替换, 或者被一个 a 后跟另一个 <a*> (它本身又可以是一个 a 或一个 a 后跟另一个 <a*> (你懂的)) 替换, 所以这些规则“产生” ¹⁵ 了句子
9.1.2 左递归与右递归
到目前为止, 语法中使用的递归产生式是所谓的右递归 (right-recursive) 产生式. 之所以这么称呼, 是因为每个产生式的递归规则都在最右端递归, 像这样:
```
<diff> := <factor>
        | <factor> '-' <diff>
```
这个小语法的右递归解析器可以很容易地打包在一个函数中 (尽管一些细节稍后会解释, 留给读者想象):
```
(define (diff x)
  (let ((left (factor x)))
    (cond ((null (rest left)) left)
          ((eq (car-of-rest left) '-')
           (let ((right (diff (cdr-of-rest left))))
             (list '- (expr left) (expr right))))
          (t left))))
```
这个解析器能够很好地识别 “-” 运算符链, 但它生成的解析树将运算符与右侧关联, 如图 6 所示.

当遍历这棵树时, 得到的前缀表达式将是
```
(- x (- y z))
```
这反过来又翻译回
```
x-(y-z)
```
然而, 它显然应该给出 (x-y)-z. 换句话说, 解析器给 “-” 运算符错误的结合性:
```
x-y-z = (- x (- y z)) ; right-associative
x-y-z = (- (- x y) z) ; left-associative
```
需要左结合性, 但得到的是右结合性. 在语法中, 这很容易通过以左递归 (left-recursive) 的方式重写它来修复, 其中递归发生在每个规则的开头:
```
<diff> := <factor>
        | <diff> '-' <factor>
```
不幸的是, 这种方法无法以上述方式实现, 正如下面的代码片段所示:
```
(define (diff x)
  (let ((left (diff x)))
    (cond ((null (rest left)) left)
          ...)))
```
因为这个假设的解析器函数会立即递归, 它永远不会到达其平凡情况, 因此会无限递归. 通过稍微重写函数, 左递归可以被消除:
```
(define (diff2 out in)
(cond ((null in)
       out)
      ((eq (car in) '-)
       (let ((right (factor (cdr in))))
         (diff2 (list '- out (expr right))
                (rest right))))
      (t out)))

(define (diff x)
  (let ((left (factor x)))
    (diff2 (expr left) (rest left))))
```
这个版本的 diff 函数将第一个因子传递给 diff2, 然后 diff2 收集 “-” 运算符 (如果有的话). Diff2 立即下降到 factor 而不是自身, 然后递归收集更多的因子. 证明它实际上构建了一个左结合表达式留作读者的练习.

9.1.2 实现

本节实现的解析器是一个所谓的递归下降解析器. 它在单独的函数中实现形式语法的每个产生式 (例如, factor 函数实现 <factor> 的规则, 等等). 就像语法的产生式一样, 这些函数形成了一个层次结构. 通过下降到这个层次结构中直到找到一个识别给定词素的函数来匹配词素. 该方法被称为递归下降, 因为函数递归以接受可变长度的输入或上升回层次结构的更高层 (例如, 用于处理括号内的子表达式).

这是代码:

(require '~rmath)

(define (infix->prefix x)
  (letrec

检查 x 是否是一个符号:

((symbol-p
   (lambda (x)
     (and (memq x '#abcdefghijklmnopqrstuvwxyz) :t)))

从输入中收集一个数字字面量, 并返回一个包含该字面量和输入其余部分的列表, 例如:

(number '#123+x ()) => '('#123 #+x)

(结果确实包含一个带引号的数字, 这不是一个错误.)

(number
  (lambda (x r)
    (cond ((or (null x)
               (not (digitp (car x))))
           (list (list 'quote (reverse r)) x))
          (t (number (cdr x) (cons (car x) r))))))

从输入中提取一个符号 (类似于 number).

(symbol
  (lambda (x)
    (list (car x) (cdr x))))

以下便利函数用于访问部分翻译的公式的各个部分. 例如, number 函数可能返回值 '(''#1 #-x*7). 这样一个结果的 car 部分是一个 zenlisp 表达式, 使用 expr 提取:

(expr '(''#1 #-x*7)) => ''#1

Rest 提取仍然需要解析的剩余输入, car-of-rest 提取 rest 的第一个字符, 而 cdr-of-rest 提取移除了第一个字符的 rest:

 (rest '(''#1 #-x*7)) => '#-x*7
(car-of-rest '(''#1 #-x*7)) => '-
(cdr-of-rest '(''#1 #-x*7)) => '#x*7

在解析公式时, 中间步骤总是保存在 expr/rest 元组中.

(expr car)
(rest cadr)
(car-of-rest caadr)
(cdr-of-rest cdadr)

factor 函数解析一个由 <factor> 产生式描述的因子. 像所有的解析函数一样, 它返回一个 expr/rest 元组:

(factor '#-123+456) => '((- '#123) '#+456)

Factor, 作为递归下降链的底部, 不能接受空输入. 因此, 当传递一个空列表时, 它会因“语法错误”而中止. 当其输入的开头词素不匹配其任何规则时, 它也会报告语法错误, 例如:

(factor '#+++) => bottom

当它找到一个左括号时, 它确保在 <sum> 之后有一个右括号.

; <factor> := '[' <sum> ']'
;            | '-' <factor>
;            | number
;            | symbol
    (factor
      (lambda (x)
        (cond ((null x)
               (bottom 'syntax 'error 'at: x))
              ((eq (car x) '[)
               (let ((xsub (sum (cdr x))))
                 (cond ((null (rest xsub))
                        (bottom 'missing-right-paren))
                       ((eq (car-of-rest xsub) '])
                        (list (expr xsub) (cdr-of-rest xsub)))
                       (t (bottom 'missing-right-paren)))))
              ((eq (car x) '-)
               (let ((fac (factor (cdr x))))
                 (list (list '- (expr fac)) (rest fac))))
              ((digitp (car x))
               (number x ()))
              ((symbol-p (car x))
               (symbol x))
              (t (bottom 'syntax 'error 'at: x)))))

Power 实现了 <power> 产生式. 它总是解析一个因子 (这就是为什么它不接受空输入), 然后递归收集由 ^ 运算符连接到目前为止解析的表达式的更多因子:

(power '#x^y^z+5) => '((expt x (expt y z)) #+5)

当一个因子后面跟着一个不是 ^ 运算符的东西 (或者当输入耗尽时), 它就停止解析.

注意, 在 power 中需要右递归, 因为幂实际上是右结合的.

; <power> := <factor>
;          | <factor> ^ <power>
(power (lambda (x)
         (let ((left (factor x)))
           (cond ((null (rest left)) left)
                 ((eq (car-of-rest left) '^)
                  (let ((right (power (cdr-of-rest left))))
                    (list (list 'expt (expr left) (expr right))
                          (rest right))))
                 (t left)))))

Term 类似于 power, 但应用了前一节中描述的左递归技巧. 它接受 * 和 / 运算符而不是 ^. 它还接受 xx 作为 x*x 的缩写:

; term := power
;       | power Symbol
;       | power * term
;       | power / term
(term2
  (lambda (out in)
    (cond ((null in) (list out in))
          ((symbol-p (car in))
           (let ((right (power in)))
             (term2 (list '* out (expr right))
                    (rest right))))
          ((eq (car in) '*)
           (let ((right (power (cdr in))))
             (term2 (list '* out (expr right))
                    (rest right))))
          ((eq (car in) '/)
           (let ((right (power (cdr in))))
             (term2 (list '/ out (expr right))
                    (rest right))))
          (t (list out in)))))
(term
  (lambda (x)
    (let ((left (power x)))
      (term2 (expr left) (rest left)))))

所有的解析函数都遵循相同的模式, 所以 sum 基本上就像 factor, power 和 term. 它与它们的区别仅在于接受的运算符. 在后面的章节中, 将展示一种避免这种代码重复的更通用的方法.

; sum := term
;      | term + sum
;      | term - sum
(sum2
  (lambda (out in)
    (cond ((null in) (list out in))
          ((eq (car in) '+)
           (let ((right (term (cdr in))))
             (sum2 (list '+ out (expr right))
                   (rest right))))
          ((eq (car in) '-)
           (let ((right (term (cdr in))))
             (sum2 (list '- out (expr right))
                   (rest right))))
          (t (list out in)))))
(sum
  (lambda (x)
    (let ((left (term x)))
      (sum2 (expr left) (rest left))))))

infix->prefix 的主体将其参数传递给 sum. 当该参数中的代码可以成功解析时, 结果元组的 rest 部分将为空. 否则, 递归下降链中的任何函数都没有处理 rest 开头词素的规则, 因此非空的 rest 表示语法错误. 例如:

(sum 'x+y@z) => '((+ x y) #@z)

当元组的 rest 部分为空时, 主体简单地返回表达式部分, 该部分此时包含完整的前缀表达式.

(let ((px (sum x)))
  (cond ((not (null (rest px)))
         (bottom (list 'syntax 'error 'at: (cadr px))))
        (t (expr px))))))

infix->prefix 程序没有显式地创建语法树. 然而, 它使用了本节中描述的方法将中缀转换为前缀表示法. 它是如何做到的？树的内部节点是什么？(Q20)

有些人会认为让 $-x^2$ 等于 $(-x)^2$ 是一个坏主意. 你能改变一元负号运算符的优先级, 使它仍然比项运算符 * 和 / 结合得更紧密, 但不像幂运算符 (^) 那样紧密吗？将你的修改实现为 BNF 语法以及 zenlisp 代码. (Q21)

2.6.2. 9.2 前缀到中缀的翻译

顾名思义, prefix->infix 是 infix->prefix 的反函数. 它接受一个由 zenlisp 形式表示的前缀表达式, 并将其转换为一个中缀表达式. 像它的表亲一样, 它保留了优先级和结合性. 它在必要时添加括号:

(prefix->infix '(+ (expt x '#2) y)) => '#x^2+y
(prefix->infix '(+ (* x '#2) (* y '#3))) => '#x*2+y*3
(prefix->infix '(- (- a b) (- c d))) => '#a-b-[c-d]

infix->prefix 和 prefix->infix 的组合可以用来从一个公式中移除 (大多数) 多余的括号:

(prefix->infix (infix->prefix '#[a+b]-[c+d])) => '#a+b-[c+d]

似乎没有一个常用的名称来称呼像 prefix->infix 这样的函数. 它们所做的是为虚拟的“中缀机”进行树遍历和代码合成的混合. 程序的大部分处理括号的生成.

这是代码:

(define (prefix->infix x)
  (letrec

ops alist 将 zenlisp 函数映射到中缀运算符, left 包含所有映射到左结合运算符的函数, 而 precedence 包含按降序排列的运算符组.

((ops '((+ . +) (- . -) (* . *) (/ . /) (expt . ^)))
 (left '#+-*/)
 (precedence '(high ([]) (expt) (* /) (+ -) low))

以下谓词用于检查形式的属性. 例如, function-p 检查一个形式是否表示一个函数, 而 left-assoc-p 当其参数是类似于左结合运算符的函数时, 求值为真. 这些函数应该很容易理解:

(function-p
  (lambda (x)
    (and (memq x '(+ - * / expt)) :t)))
(left-assoc-p
  (lambda (x)
    (and (memq x left))))
(symbol-p
  (lambda (x)
    (and (memq x '#abcdefghijklmnopqrstuvwxyz) :t)))
(numeric-p
  (lambda (x)
    (and (not (atom x))
         (eq (car x) 'quote))))
(atomic-p
  (lambda (x)
    (or (function-p x)
        (symbol-p x)
        (numeric-p x))))

Unary-p 检查一个形式是否表示一个一元函数应用:

(unary-p
  (lambda (x)
    (and (not (null (cdr x)))
         (null (cddr x)))))

higher-prec-p 函数判断公式 x 是否比公式 y 具有更高的优先级. 例如:

(higher-prec-p '#1 '(+ a b)) => :t
(higher-prec-p '(* a b) (+ a b)) => :t
(higher-prec-p '(- a) (expt a b)) => :t
(higher-prec-p '(- a) 'a) => :f

原子形式 (符号、数字) 具有最高的优先级 (因为它们是原子的), 其次是一元运算符和 precedence 列表中表示的优先级规则.

(higher-prec-p
  (lambda (x y)
    (letrec
      ((hpp (lambda (x y prec)
              (cond ((atom prec) :f)
                    ((memq x (car prec))
                     (not (memq y (car prec))))
                    ((memq y (car prec)) :f)
                    (t (hpp x y (cdr prec)))))))
      (cond ((atomic-p x) (not (atomic-p y)))
            ((atomic-p y) :f)
            ((unary-p x) (not (unary-p y)))
            ((unary-p y) :f)
            (t (hpp (car x) (car y) (cdr precedence)))))))

Paren 在给定的表达式周围放置括号 ([ 和 ]), 但从不在原子周围.

(paren
  (lambda (x)
    (cond ((atomic-p x) x)
          (t (list '[] x)))))

add-parens 函数向表达式添加括号标签:

(add-parens '(* (+ a b) c)) => '(* ([] (+ a b)) c)

[] (“parens”) 符号表示在转换为中缀时, 以下子表达式必须放在括号中以保持优先级. Add-parens 只标记那些真正需要显式分组的子表达式:

(add-parens '(+ (* a b) c)) => '(+ (* a b) c)

当一个原子形式传递给 add-parens 时, 它只是返回它, 否则它首先通过 map 递归处理子形式. 最后, 它应用我们知道的优先级规则.

当当前公式是一元函数的应用, 且参数既不是原子也不是另一个一元函数时, 参数被放在括号中.

当当前公式是左结合二元函数的应用时, 如果公式的运算符比参数的运算符具有更高的优先级, 则左参数被放在括号中:

(add-parens '(* (+ a b) c)) => '(* ([] (+ a b)) c)

如果第二个参数的优先级不高于公式的运算符 (也就是说, 如果它的优先级低于或等于公式的运算符), 则它被放在括号中:

(add-parens '(* a (+ b c))) => '(* a ([] (+ b c)))

后一个规则也标记了在相同优先级水平上向右分组的操作.

(add-parens '(- a (- b c))) => '(- a ([] (- b c)))

右结合操作的规则 (add-parens 的内部 cond 的 catch-all 子句) 与上述类似, 但规则被改变, 以便在相同优先级水平上向左分组的操作被标记.

(add-parens
  (lambda (x)
    (cond
      ((atomic-p x) x)
      (t (let ((x (map add-parens x)))
           (cond ((unary-p x)
                  (cond ((atomic-p (cadr x)) x)
                        ((unary-p (cadr x)) x)
                        (t (list (car x)
                                 (paren (cadr x))))))
                 ((left-assoc-p (car x))
                  (list (car x)
                        (cond ((higher-prec-p x (cadr x))
                               (paren (cadr x)))
                              (t (cadr x)))
                        (cond ((higher-prec-p (caddr x) x)
                               (caddr x))
                              (t (paren (caddr x))))))
                 (t (list (car x)
                          (cond ((higher-prec-p (cadr x) x)
                                 (cadr x))
                                (t (paren (cadr x))))
                          (cond ((higher-prec-p x (caddr x))
                                 (paren (caddr x)))
                                (t (caddr x)))))))))))

infix 函数遍历由 zenlisp 形式表示的树, 并发出一个中缀表达式. 它将由 [] 标记的子表达式用括号括起来:

(infix '(* (+ x y) z)) => '#x+y*z
(infix '(* ([] (+ x y)) z)) => '#[x+y]*z

Infix 还检查 zenlisp 表达式的一致性 (语法) 并报告错误.

(infix
  (lambda (x)
    (cond
      ((numeric-p x)
       (cadr x))
      ((symbol-p x)
       (list x))
      ((and (eq (car x) '-)
            (not (atom (cdr x)))
            (null (cddr x)))
       (append '#- (infix (cadr x))))
      ((and (eq (car x) '[])
            (not (atom (cdr x)))
            (null (cddr x)))
       (append '#[ (infix (cadr x)) '#]))
      ((and (not (atom x))
            (not (atom (cdr x)))
            (not (atom (cddr x)))
            (null (cdddr x))
            (function-p (car x)))
       (append (infix (cadr x))
               (list (cdr (assq (car x) ops)))
               (infix (caddr x))))
      (t (bottom (list 'syntax 'error: x)))))))

主体部分简单地组合了 add-parens 和 infix.

(infix (add-parens x))))

你能以这样一种方式重写 prefix->infix, 使它在所有操作周围都加上括号, 从而使优先级显式化吗？这种转换会有什么实际应用？(Q22)

你能让 prefix->infix 发出逆波兰表示法 (RPN, 后缀表示法) 而不是中缀表示法吗？例如:

(prefix->rpn '(* (+ x y) z)) => '#xy+z*

RPN 需要括号吗？为什么？(Q23)

注意, prefix->infix 有时会添加多余的括号:

(prefix->infix '(+ x (+ y z))) => '#x+[y+z]

这是因为该程序没有实现交换律 (commutativity). 如果 o 运算链与结合性无关, 那么运算符 o 是可交换的:

(a o b) o c = a o (b o c)

和 * 运算符是可交换的. 你能在 add-parens 中实现识别交换律并跳过可能括号的规则吗？

2.6.3. 9.3 正则表达式

正则表达式 (RE) 是一种用于匹配字符序列的模式. RE 比字符串更通用, 因为它允许包含匹配字符类别或字符或字符序列的“特殊”字符. 细节将立即解释.

本章介绍的函数实现了现在所谓的“基本”正则表达式. 这是“传统”Unix 和早期版本的 grep(1) 实用程序中使用的 RE 格式.

正则表达式由一组字符和运算符组成. 大多数字符只匹配它们自己, 所以 RE foo 会匹配序列 foo, 甚至序列 afoob, 因为它包含 foo.

以下字符在 RE 中有特殊含义: ¹⁶

9.3.1 正则表达式编译

以下列表定义了 RE 函数将操作的字符集. 用 __ 替换的字符不能用符号表示. 该集合基本上是 ASCII 的一个子集, 不包括控制字符块和为 zenlisp 语言保留的符号. 因为解释器不区分大小写字符, 所以它们被认为是相等的.

(define character-set
  '(__ ! " __ $ % & __ __ __ * + , - __ /
    0 1 2 3 4 5 6 7 8 9 : __ < = > ?
    @ a b c d e f g h i j k l m n o
    p q r s t u v w x y z [ \ ] ^ _
    ` a b c d e f g h i j k l m n o
    p q r s t u v w x y z __ | __ ~ __))

Pair-p 只是一个捷径.

(define (pair-p x) (not (atom x)))

before-p 谓词检查字符 c0 是否在 character-set 中出现在字符 c1 之前. 它将用于检查字符类中的 “-” 运算符.

(define (before-p c0 c1)
  (letrec
    ((lt (lambda (set)
           (cond ((null set) (bottom (list before-b c0 c1)))
                 ((eq c1 (car set)) :f)
                 ((eq c0 (car set)) :t)
                 (t (lt (cdr set)))))))
    (lt character-set)))

Make-range 将一个新范围 (从 c0 到 cn) 添加到类 cls 中, 例如:

(make-range 'a 'f '#9876543210) => '#fedcba9876543210

它用于在类中展开 “-” 运算符.

(define (make-range c0 cn cls)
  (letrec
    ((make
       (lambda (c cls)
         (cond ((null c)
                (bottom 'invalid-symbol-code cn))
               ((eq (car c) cn)
                (cons (car c) cls))
               (t (make (cdr c)
                        (cons (car c) cls)))))))
    (let ((c (memq c0 character-set)))
      (cond (c (make c cls))
            (t (bottom 'invalid-symbol-code c0))))))

compile-class 函数编译参数 in 开头的字符类, 并将其 cons 到 out 上. cls 参数持有运算符 [, 它将用于在结果 CRE 中指示一个类. 在编译补集类 (以 [^ 开头) 时, 此运算符将更改为 ]. First 是一个标志, 最初设置为“真”, 以指示 compile-class 当前正在处理类的第一个字符. 它用于识别 ^ 运算符. 该函数返回一个列表, 其中包含其输入的其余部分作为其第一个成员, 编译后的类作为其第二个成员:

(compile-class '#0-9] () '#[ :t) => '(() (#[0123456789))
(compile-class '#^0-9] () '#[ :t) => '(() (#]0123456789))
(compile-class '#0-9]xyz () '#[ :t) => '(#xyz (#[0123456789))

当无效输入传递给 compile-class 时, 它返回 :f:

(compile-class '#0-9 () '#[ :t) => :f ; missing ]

注意, 类运算符本身 ([) 必须由 compile-class 的调用者消耗.

(define (compile-class in out cls first)
  (cond
    ((null in) :f)
    ((eq '] (car in))
     (list (cdr in) (cons (reverse cls) out)))
    ((and first (eq '^ (car in)))
     (compile-class (cdr in) out '#] :f))
    ((and (not first)
          (not (null (cdr cls)))
          (eq '- (car in))
          (pair-p (cdr in))
          (not (eq '] (cadr in))))
     (let ((c0 (car cls))
           (cn (cadr in)))
       (cond
         ((before-p c0 cn)
          (compile-class (cddr in)
                         out
                         (make-range c0 cn (cdr cls)) :f))
         (t (compile-class (cdr in)
                           out
                           (cons '- cls) :f)))))
    (t (compile-class (cdr in)
                      out
                      (cons (car in) cls) :f))))

re-compile 函数将一个 RE 编译为一个编译后的 RE (CRE). RE 到 CRE 的映射如下:

re	cre
[class]	'#[class
[^class]	'#]class
pattern*	(* pattern)
pattern+	pattern (* pattern)
pattern?	(? pattern)
^	#^
$	#$
\c	c

所以, 例如:

(re-compile '#\*[a-c]+[^d-f]*\*) => '(* #[abc (* #[abc) (* #]def) *)

注意, pattern+ 编译为 pattern (* pattern); 没有单独的 CRE 运算符实现 +. 当传递无效的 RE 时, Re-compile 返回 :f.

(define (re-compile re)
  (letrec
    ((compile
       (lambda (in out)
         (cond
           ((not in) :f)
           ((null in) (reverse out))
           (t (cond
                ((eq (car in) '\)
                 (cond ((pair-p (cdr in))
                        (compile (cddr in)
                                 (cons (cadr in) out)))
                       (t :f)))
                ((memq (car in) '#^$_)
                 (compile (cdr in)
                          (cons (list (car in)) out)))
                ((memq (car in) '#*?)
                 (compile (cdr in)
                          (cond ((null out)
                                 (cons (car in) out))
                                (t (cons (list (car in) (car out))
                                         (cdr out))))))
                ((eq (car in) '+)
                 (compile (cdr in)
                          (cond ((null out)
                                 (cons (car in) out))
                                (t (cons (list '* (car out)) out)))))
                ((eq (car in) '[)
                 (apply compile
                        (compile-class (cdr in) out '#[ :t)))
                (t (compile (cdr in)
                            (cons (car in) out)))))))))
    (compile re ())))

9.3.2 正则表达式匹配

match-char 函数将一个字符 (由单字符符号表示) 与另一个字符或字符类进行匹配. 例如:

(match-char 'x 'x) => :t
(match-char '#]abc 'x) => :t
(match-char '_ 'x) => :t
(match-char '#[123 'x) => :f

当模式 p 匹配字符 c 时, 它返回真, 否则返回假.

(define (match-char p c)
  (cond ((eq '_ p)
         :t)
        ((atom p)
         (eq p c))
        ((eq '[ (car p))
         (and (memq c (cdr p)) :t))
        ((eq '] (car p))
         (not (memq c (cdr p))))
        (t :f)))

Make-choices 使用 * 运算符为匹配子序列生成备选项. 例如, 当将模式 [a-f]* 与序列 abc123 匹配时, 存在以下备选项:

(make-choices '((* #[abcdef)) '#abc123 ())
=> '((#abc123 ())
     (#bc123 #a)
     (#c123 #ba)
     (#123 #cba))

当最长匹配导致 RE 的其余部分不匹配时, 这些备选项用于回溯 (backtrack). 例如, 当将 RE a*ab 与序列 aaaab 匹配时, a* 模式可以匹配 aaaa, 但随后的模式 ab 将不匹配 b, 因此匹配将失败. 通过回溯, 匹配器将尝试将 a* 与 aaa 关联. 在这种情况下, ab 与 ab 匹配, 因此整个 RE 匹配:

(re-match (re-compile '#a*ab) '#aaaab) => '#aaaab

注意: 由 make-choices 创建的选项确实包括一个空匹配. make-choices 的 m 参数最初必须是 ().

make-choices 返回的值包含要在其 car 部分中匹配的序列的其余部分, 以及在其 cadr 部分中匹配的序列部分. 匹配的部分以反向顺序返回, 因为它将在稍后的过程中传递给 match-cre (见下文).

(define (make-choices p s m)
  (cond
    ((or (null s)
         (not (match-char (cadar p) (car s))))
     (list (list s m)))
    (t (cons (list s m)
             (make-choices p (cdr s) (cons (car s) m))))))

match-star 函数尝试由 make-choices 生成的备选项, 并找到不使 RE 的其余部分失败的最长匹配. 注意, 它返回由 CRE 的完整剩余部分匹配的序列, 而不仅仅是为其开头的 * 运算符找到的最长匹配:

(match-star '((* a) a b) '#aaaab ()) => '#aaaab

Match-star 反转 make-choices 的结果, 因为它首先列出最短的匹配.

(define (match-star cre s m)
  (letrec
    ((try-choices
       (lambda (c*)
         (cond ((null c*) :f)
               (t (let ((r (match-cre (cdr cre) (caar c*) (cadar c*))))
                    (cond (r (append (reverse m) r))
                          (t (try-choices (cdr c*))))))))))
    (try-choices (reverse (make-choices cre s ())))))

match-cre 函数匹配除 ^ 之外的所有字符和运算符. 它将编译后的 RE 与序列 s 进行匹配. 匹配从序列的开头开始, 所以 match-cre 不会找到稍后出现在 s 中的 RE 的出现:

(match-cre '((* #[ab) c) '#1abc2 ()) => :f

一个已经匹配的部分可以使用 m 参数传递给 matche-cre, 但它必须是反向的, 因为 matche-cre 会对其进行 cons 操作, 并在完成时反转 m.

(define (match-cre cre s m)
  (cond
    ((null cre)
     (reverse m))
    ((null s)
     (cond ((equal cre '(#$))
            (match-cre () () m))
           ((and (pair-p (car cre))
                 (eq '* (caar cre))
                 (null (cdr cre)))
            ())
           (t :f)))
    ((pair-p (car cre))
     (cond
       ((eq '* (caar cre))
        (match-star cre s m))
       ((eq '? (caar cre))
        (cond ((match-char (cadar cre) (car s))
               (match-cre (cdr cre) (cdr s) (cons (car s) m)))
              (t (match-cre (cdr cre) s m))))
       ((match-char (car cre) (car s))
        (match-cre (cdr cre) (cdr s) (cons (car s) m)))
       (t :f)))
    ((eq (car cre) (car s))
     (match-cre (cdr cre) (cdr s) (cons (car s) m)))
    (t :f)))

Try-matches 尝试将给定的 RE 匹配到给定序列的每个尾部, 所以不像 match-cre, 它也匹配稍后在序列中开始的 RE 的出现:

(try-matches '((* #[ab) c) '#1abc2) => '#abc

Try-matches 在遍历序列时不接受空匹配. 只有当序列被完全访问而没有找到非空匹配时, 才会尝试一个空匹配作为最后的手段.

(define (try-matches cre s)
  (cond ((null s) (match-cre cre s ()))
        (t (let ((r (match-cre cre s ())))
             (cond ((or (not r) (null r))
                    (try-matches cre (cdr s)))
                   (t r))))))

re-match 函数将编译后的正则表达式 cre 与序列 s 进行匹配. 当 CRE 以 ^ 运算符开头时, 使用 match-cre 来匹配 RE, 否则使用 try-matches.

(define (re-match cre s)
  (cond ((and (pair-p cre) (equal '#^ (car cre)))
         (match-cre (cdr cre) s ()))
        (t (try-matches cre s))))

以下 RE 是如何解释的？它们应该如何解释？(Q24)

(re-compile '#[-x])
(re-compile '#[x-])
(re-compile '#[])
(re-compile '#[^])

为什么正则表达式要分开编译和匹配？一步编译和匹配不是更容易吗？

make-choices 函数为重复模式创建所有潜在的匹配, 但实际上只使用它的一个结果. 你能以这样一种方式修改代码, 使它只在当前选择不匹配时才创建下一个选择吗？

你能将本节介绍的 RE 匹配器变成一个最短匹配优先的实现吗？(Q25)

2.6.4. 9.4 元循环解释

一种语言 L 的元循环解释器 (meta-circular interpreter) 是一个本身用 L 编写的解释器, 它利用宿主解释器提供的函数和其他设施, 而不是重新实现它们. 元循环解释器能够解释它们自己, 所以每当运行一个元循环解释器时, 都有一个“外部”和一个“内部”解释器, 即一个运行 (内部) 解释器的解释器和一个运行程序的解释器. 这个原理在图 7 中得到了说明.

内部解释器是一个元循环解释器 M, 而外部解释器可以是 M 的另一个实例或一个“原生”解释器.

这个原理很好地说明了“解释”与“编译”的问题是一个虚幻的问题: 一个元循环解释器被一个原生解释器解释, 而原生解释器要么被解释, 要么被“编译”. 当它被编译时, 它实际上是被 CPU 解释的. CPU 指令被微码解释, 微码被晶体管解释. 晶体管的功能被自然法则解释. 所以, 除非你的程序直接由自然法则执行, 否则它并不是真正高效的, 但可能更易于理解.

一个用于 zenlisp 的元循环解释器不会自己实现像 cons 这样的函数, 而是简单地将 cons 的应用委托给外部解释器的原始 cons 函数 (见图 7). 这样的解释器也不会使用解析器, 因为 zenlisp 程序就是 zenlisp 数据, 所以会使用外部解释器的解析器 (读取器).

本节讨论的 zeval 函数实现了一个用于 zenlisp 的元循环解释器 (模 define 和元函数). 它接受一个程序和一个环境作为其参数, 并在给定的环境中返回该程序的范式:

(zeval '(letrec
          ((append
             (lambda (a b)
               (cond ((null a) b)
                     (t (cons (car a)
                              (append (cdr a) b)))))))
          (append '#hello- '#world!))
        (list (cons 'null null)))
=> '#hello-world!

注意, null 函数必须在环境中传递给 zeval, 因为 zeval 只实现了语言的核心部分. 添加更多函数留作读者的练习.

zeval 的代码不像你可能在文献中找到的其他一些元循环解释器那么简单, 因为它在常数空间内解释尾递归程序. 这是代码:

(define (zeval x e)
  (letrec

解释器的初始环境包含 zenlisp 的关键字, 符号 :t, :f, 和 t, 以及一组不参考外部解释器就难以轻松实现的函数. 初始环境可以被认为是构建 zenlisp 所需的符号、关键字和函数的合理最小集.

((initial-env
   (list (cons 'closure 'closure)
         (cons 't ':t)
         (cons ':t ':t)
         (cons ':f ':f)
         (cons 'and '(%special . and))
         (cons 'apply '(%special . apply))
         (cons 'cond '(%special . cond))
         (cons 'eval '(%special . eval))
         (cons 'lambda '(%special . lambda))
         (cons 'let '(%special . let))
         (cons 'letrec '(%special . letrec))
         (cons 'or '(%special . or))
         (cons 'quote '(%special . quote))
         (cons 'atom (cons '%primitive atom))
         (cons 'bottom (cons '%primitive bottom))
         (cons 'car (cons '%primitive car))
         (cons 'cdr (cons '%primitive cdr))
         (cons 'cons (cons '%primitive cons))
         (cons 'defined (cons '%primitive defined))
         (cons 'eq (cons '%primitive eq))
         (cons 'explode (cons '%primitive explode))
         (cons 'implode (cons '%primitive implode))
         (cons 'recursive-bind (cons '%primitive recursive-bind))))

Value-of 在一个关联列表中查找与一个符号关联的值并返回它. 与 assq 不同, 当符号不在 alist 中或与特殊值 %void 关联时, 它会产生 bottom. 这个函数用于在环境 (实现为 alist) 中查找变量的值.

(value-of
  (lambda (x e)
    (let ((v (assq x e)))
      (cond ((or (not v) (eq (cdr v) '%void))
             (bottom 'undefined: x))
            (t (cdr v))))))

Ev-list 在环境 e 中求值 x 的所有成员, 并返回一个包含它们范式的列表. 它用于求值函数参数.

(ev-list
  (lambda (x e)
    (cond ((null x) ())
          ((atom x) (bottom 'improper-list-in-application: x))
          (t (cons (ev (car x) e)
                   (ev-list (cdr x) e))))))

Check-args 检查参数列表 a 是否有 n 个参数 (如果设置了 more 标志, 则 >=n). Wrong-args 报告错误的参数计数. Args-ok 是这些函数的前端. 它由原语调用, 以确保提供了正确数量的参数.

(check-args
  (lambda (a n more)
    (cond ((null n) (or more (null a)))
          ((null a) :f)
          (t (check-args (cdr a)
                         (cdr n)
                         more)))))
(wrong-args
  (lambda (name args)
    (bottom 'wrong-number-of-arguments:
            (cons name args))))
(args-ok
  (lambda (name a n more)
    (cond ((check-args a n more) :t)
          (t (wrong-args name a)))))

eval-until 函数在环境 e 中求值列表 a 的成员. 一旦 a 的一个成员求值为 t/f, eval-until 立即返回 (quote t/f). 当没有成员归约为 t/f 时, 它返回 a 的最后一个成员 (不是该成员的范式).

Eval-until 用于实现 and 和 or 关键字. 它以未求值状态返回最后一个形式, 因为在原地求值会破坏尾递归. 这在后面的代码中会变得清晰.

注意, t/f 必须是 :t 或 :f. 当它是 :t 时, 它会匹配任何“真”值, 因为它在 eval-until 中的检查方式.

(eval-until
  (lambda (t/f a e)
    (cond ((null (cdr a)) (car a))
          ((atom a) (bottom 'improper-list-in-and/or: a))
          (t (let ((v (ev (car a) e)))
               (cond ((eq (not v) (not t/f))
                      (list 'quote v))
                     (t (eval-until t/f (cdr a) e))))))))

Do-and 使用 eval-until 来实现 and.

(do-and
  (lambda (a e)
    (cond ((null a) :t)
          (t (eval-until :f a e)))))

clause-p 和 do-cond 函数实现 cond. Clause-p 检查 cond 的一个子句在语法上是否正确.

Do-cond 首先做很多检查. cond 的语义在最后一个子句中实现, 该子句遍历子句并返回与第一个“真”谓词关联的表达式. 像 do-and 中一样, 表达式以未求值的形式返回.

(clause-p
  (lambda (x)
    (and (not (atom x))
         (not (atom (cdr x)))
         (null (cddr x)))))
(do-cond
  (lambda (a e)
    (cond ((null a)
           (bottom 'no-default-in-cond))
          ((atom a)
           (bottom 'improper-list-in-cond))
          ((not (clause-p (car a)))
           (bottom 'bad-clause-in-cond: (car a)))
          (t (let ((v (ev (caar a) e)))
               (cond (v (cadar a))
                     (t (do-cond (cdr a) e))))))))

Do-eval 实现 eval. 它只是将其参数传递给解释器.

(do-eval
  (lambda (args e)
    (and (args-ok 'eval args '#i :f)
         (ev (car args) e))))

lambda-args 函数将一个参数列表 (可能是一个列表、一个点分列表, 甚至一个符号) 转换为一个适当的列表:

(lambda-args '(x y)) => '(x y)
(lambda-args '(x . y)) => '(x y)
(lambda-args 'x) => '(x)

它的代码很简单:

(lambda-args
  (lambda (a)
    (cond ((null a) ())
          ((atom a) (list a))
          (t (cons (car a)
                   (lambda-args (cdr a)))))))

Add-free-var 为自由变量 var 添加一个绑定到环境 fenv. 变量 e 是一个 var 可能被绑定的环境 (它也可能未被绑定). 这里有一些例子:

(add-free-var '((a . b)) 'a ()) => '((a . b))
(add-free-var () 'a '((a . x))) => '((a . x))
(add-free-var () 'a ()) => '((a . %void))

如果变量已经在 fenv 中, 它就不会再被添加. 如果它不在 fenv 中但在 e 中, 则 e 的绑定被复制到 fenv. 如果 var 既不在 fenv 也不在 e 中, 则创建一个新的绑定, 将该变量与特殊符号 %void 关联. 这个符号表示该变量没有绑定到任何值.

(add-free-var
  (lambda (fenv var e)
    (cond ((assq var fenv) fenv)
          (t (let ((v (assq var e)))
               (cond (v (cons v fenv))
                     (t (cons (cons var '%void) fenv))))))))

capture 函数创建当前环境所有自由变量的快照. 它用于在创建闭包时捕获词法环境. Bound 是绑定变量的列表, x 是要捕获其变量的表达式, e 是当前活动的环境.

(capture
  (lambda (bound x e)
    (letrec
      ((collect
         (lambda (x free)
           (cond ((null x) free)
                 ((atom x)
                  (cond ((memq x bound) free)
                        (t (add-free-var free x e))))
                 (t (collect (car x)
                             (collect (cdr x) free)))))))
      (collect x ()))))

Do-lambda 实现 lambda. 它返回一个闭包.

(do-lambda
  (lambda (args e)
    (and (args-ok 'lambda args '#ii :f)
         (list 'closure
               (car args)
               (cadr args)
               (capture (lambda-args (car args))
                        (cadr args)
                        e)))))

Do-or 实现 or. 这里没什么惊喜.

(do-or
  (lambda (a e)
    (cond ((null a) :f)
          (t (eval-until :t a e)))))

Do-quote 实现 quote 关键字. 它只是返回其参数. 注意, 解释器不显式支持 'x 来代替 (quote x). 这是不必要的, 因为 'x 被读取器展开, 所以 zeval 从来看不到未展开的形式.

(do-quote
  (lambda (args)
    (and (args-ok 'quote args '#i :f)
         (car args))))

make-env 函数从变量列表 (形式参数) fa 和 (实际) 参数列表 aa 创建一个新环境. 当参数数量不匹配时, 它归约为 bottom. 该函数正确处理可变参数列表:

(make-env '(a . b) '(x y z)) => '((a . x) (b . (y z)))
(make-env 'a '(x y z)) => '((a . (x y z)))

Make-env 用于在函数应用中将变量绑定到参数.

(make-env
  (lambda (fa aa)
    (cond ((null fa)
           (cond ((null aa) ())
                 (t (bottom 'too-many-arguments))))
          ((atom fa)
           (list (cons fa aa)))
          ((null aa)
           (bottom 'too-few-arguments))
          (t (cons (cons (car fa) (car aa))
                   (make-env (cdr fa) (cdr aa)))))))

beta 函数实现了 beta 归约 (也见 page 59). 它通过以下部分环境的并集来扩展当前的外部环境 e:

fa 中变量到 aa 中参数的绑定;
词法环境 lex-env;
当前内部环境 le (局部环境).

它还将 fix 函数应用于由 fa 和 aa 形成的新局部绑定. 当 fix=id 时, beta 实现普通 beta 归约, 如在 lambda 和 let 中. 当 fix=recursive-bind 时, 它实现 letrec.

最后, beta 求值表达式 expr. 它将内部 (e) 和外部环境 (le) 都传递给 ev2. 这是为了实现尾递归.

(beta
  (lambda (expr fa aa lex-env e le fix)
    (ev2 expr e (append (fix (make-env fa aa)) lex-env le))))

Do-let/rec 实现 let 和 letrec. 它只是从构造中提取变量和参数, 并将它们传递给 beta. Le 和 e 是当前的内部和外部环境. fix 参数在上面解释.

binding-p 辅助函数利用了子句与绑定具有相同语法的事实.

(binding-p
  (lambda (x)
    (clause-p x)))
(do-let/rec
  (lambda (args e le fix)
    (cond ((not (args-ok 'let/letrec args '#ii :f)) :f)
          ((not (apply and (map binding-p (car args))))
           (bottom 'bad-let/letrec-syntax: (car args)))
          (t (let ((formals (map car (car args)))
                   (actuals (map cadr (car args))))
               (beta (cadr args)
                     formals
                     (ev-list actuals le)
                     ()
                     e le fix))))))

Apply-fn 将函数 fn 应用于形式参数 args. 此时参数已经是它们的范式. 环境 e 和 le 只是被传递过去.

(apply-fn
  (lambda (fn args e le)
    (cond ((eq (car fn) '%primitive)
           (apply (cdr fn) args))
          ((eq (car fn) '%special)
           (apply-special (cdr fn) args e le))
          ((eq (car fn) 'closure)
           (beta (caddr fn)
                 (cadr fn)
                 args
                 (cadddr fn)
                 e le id))
          (t (bottom 'application-of-non-function: fn)))))

make-args 函数为 apply 创建一个参数列表. 因为 apply 本身是可变参数的, 它收集可选的参数, 并确保最后一个是列表:

(make-args '(a b c '(d e))) => '#abcde
(make-args '(a b c d)) => bottom

这是代码:

(make-args
  (lambda (a)
    (cond ((null (cdr a))
           (cond ((atom (car a))
                  (bottom 'improper-argument-list:
                          (car a)))
                 (t (car a))))
          (t (cons (car a) (make-args (cdr a)))))))

Apply-special 解释 zenlisp 的关键字 (除了 define). 它将伪函数 fn 应用于参数 args. 因为 fn 是一个伪函数, 所以参数是未求值的, 而不是它们的范式.

注意, apply-special 的一些情况将特殊形式处理程序返回的值传递给 ev2, 而一些则简单地返回它. 这是因为一些特殊形式处理程序 (对于 and, cond 等) 返回仍然需要归约为其范式的表达式, 而另一些则立即返回范式 (比如 lambda, quote 等的处理程序).

还有一些 (比如 let, letrec 和 apply 的处理程序) 自己调用 ev2, 所以它们是间接递归的. 因为像 do-let/rec 这样的处理程序是在尾部位置调用的, 所以递归仍然发生在常数空间内.

(apply-special
  (lambda (fn args e le)
    (cond ((eq fn 'and)
           (ev2 (do-and args le) e le))
          ((eq fn 'apply)
           (let ((args (ev-list args le)))
             (and (args-ok 'apply args '#ii :t)
                  (apply-fn (car args)
                            (make-args (cdr args))
                            e
                            e))))
          ((eq fn 'cond)
           (ev2 (do-cond args le) e le))
          ((eq fn 'eval)
           (ev2 (do-eval args le) e le))
          ((eq fn 'lambda)
           (do-lambda args le))
          ((eq fn 'let)
           (do-let/rec args e le id))
          ((eq fn 'letrec)
           (do-let/rec args e le recursive-bind))
          ((eq fn 'or)
           (ev2 (do-or args le) e le))
          ((eq fn 'quote)
           (do-quote args))
          (t (bottom 'internal:bad-special-operator: fn)))))

这些谓词检查一个对象是函数还是特殊形式处理程序.

(function-p
  (lambda (x)
    (or (eq (car x) '%primitive)
        (eq (car x) 'closure))))
(special-p
  (lambda (x)
    (eq (car x) '%special)))

Ev2 将表达式 x 在环境 le 中归约为其范式. 参数 e 持有当前的外部环境. 最初, e 等于 le.

为了确定如何处理一个列表, ev2 在 le 中归约列表的 car 部分. 如果结果范式 f 是一个函数, 它在 le 中求值函数参数 (列表的 cdr 部分), 然后通过设置 new-e=e 来丢弃内部环境. 如果 f 是一个特殊形式处理程序, 函数参数不被求值, 并且内部环境被保留.

在求值函数参数后放弃内部环境实现了尾递归.

(ev2
  (lambda (x e le)
    (cond
      ((null x) ())
      ((atom x) (value-of x le))
      (t (let ((f (ev (car x) le)))
           (cond ((eq f 'closure) x)
                 ((atom f)
                  (bottom 'application-of-non-function: f))
                 (t (let ((args (cond ((function-p f)
                                      (ev-list (cdr x) le))
                                     (t (cdr x))))
                          (new-e (cond ((special-p f) le)
                                       (t e))))
                      (apply-fn f args e new-e)))))))))

这只是 e=le 情况的一个缩写.

(ev (lambda (x e)
      (ev2 x e e))))

传递给 zeval 的环境在启动解释器之前附加到初始环境:

(ev x (append e initial-env))))

你能以这样一种方式重写 zeval, 使它实际上可以解释自己吗？

原语只是被传递给宿主解释器, 例如 cons 是由实现外部解释器中 cons 的代码解释的. 为什么不可能将特殊形式的求值委托给外部解释器的特殊形式处理程序？(Q26)

Zeval 使用像 %special 和 %void 这样的符号来标记特殊值. 当要由 zeval 解释的程序包含这样的符号时, 这个细节会引起任何麻烦吗？你能做些什么？(Q27)

2.7. 10. mexprc – 一个 m-表达式编译器

本章将使用前一章介绍的一些技术来实现一个完整编程语言的编译器.

M-表达式 (元表达式) 构成了最初为 LISP 设计的语法. 在最初的设计中, S-表达式仅用于表示数据, 而 M-表达式用于编写程序. S-表达式基本上等同于 zenlisp 形式.

以下是 John McCarthy 的 ACM 论文“LISP 的历史”¹⁸ 中的一段引文, 解释了为什么最终使用 S-表达式代替 M-表达式:

2.7.1. 10.1 规范

M-表达式类似于 FORTRAN, C, Java 和其他编程语言中使用的中缀表示法. 数字表示它们自己, 常用的运算符用于表示数学运算, 如减法、乘法等. 由于 ASCII 字符集中缺少合适的字符, 逻辑与和或分别由序列 \ 和 \ 表示, 右箭头写成 ->.

“真正的”M-表达式会使用字符 (, ), 和 ;, 但 MEXPRC 编译器无法以这种方式实现它们, 因为这些字符不能作为数据包含在 zenlisp 程序中. 因此, 规范必须稍作调整:

表达式分组由 [ 和 ] 完成, 而不是 ( 和 );
字面量列表由 << 和 >> 分隔, 而不是 ( 和 );
函数参数使用 , 分隔, 而不是 ;;
条件运算符写成 [a->b:c] 而不是 [a->b;c];
常量以 % 为前缀, 而不是使用大写字母.

这里有一些 M-表达式示例及其对应的 S-表达式:

M-expression	S-expression
cons[a,b]	(cons a b)
a::b	(cons a b)
%a::%b	(cons 'a 'b)
%a::	(cons 'a '(b c d))
append[a,b]	(append a b)
a++b	(append a b)
a*b-c/d	(- (* a b) (/ c d))
[a+b]*c	(* (+ a b) c)
[a/\b-> c: d]	(cond ((and a b) c) (t d))
f[x] := x²	(define (f x) (expt x 2))
lambda[[x] cons[x,x]]	(lambda (x) (cons x x))
lambda[[x] x][%a]	((lambda (x) x) 'a)
not[x] :=	(define (not x)
[x-> false: true]	(cond (x :f) (t :t)))
fact[x] :=	(define (fact x)
[x=0	(cond ((= x 0)
-> 1:	1)
fact[x-1]*x]	(t (* (fact (- x 1)) x))))
f[x] := g[x]	(define (f x)
where g[x] := h[x]	(letrec ((g (lambda (x) (h x)))
and h[x] := x	(h (lambda (x) x)))
	(g x)))

MEXPRC 接受的源语言的完整语法在下面的 BNF 语法中描述. 该语法使用连接运算符 &, 这在 BNF 语法中通常找不到. 形式为

a* := a | a & a*

的规则只匹配不包含任何空格字符的 a 序列, 例如, 上面的规则匹配

aaaaaa

但不匹配

a a a a a a

连接运算符 (&) 比或运算符 (|) 结合得更紧密. 它们用于引入标记类, 如表示数字的数字序列或表示符号的字符序列.

语法的一些规则用 S-表达式进行了注释, 指示由该规则匹配的句子应翻译成什么. 这种注释在半形式化地指定语言的语义时很常见. 例如, 规则

concatenation :=
 factor '::' concatenation ; (cons factor concatenation)

表明上述形式的每个句子都表示 cons 的一个应用. 像 zenlisp 的注释一样, 注释由分号引入, 并延伸到当前行的末尾.

10.1.1 带注释的语法

注意: 在这个语法中, 非终结符没有尖括号. 所有终结符都用撇号括起来.

mexpr := definition
       | expression

numeric-char := '0' | ...| '9'

symbolic-char := 'a' | ...| 'z' | '_'

number := numeric-char
        | number & numeric-char

symbol := symbolic-char
        | symbol & symbolic-char

list-member := symbol
             | list

list-members := list-member
              | list-member list-members

list := '<<' list-members '>>' ; (quote (list-members))
      | '<<' '>>'               ; ()

list-of-expressions := expression
                     | expression ',' list-of-expressions
list-of-symbols := symbol
                 | symbol ',' list-of-symbols

cases := case
       | case ':' cases

case := expression '->' expression

factor :=
  number                               ; number
  | symbol                             ; variable
  | '%' symbol                         ; (quote symbol)
  | 'true'                              ; :t
  | 'false'                             ; :f
  | '-' factor                         ; (- factor)
  | symbol '[' list-of-expressions ']' ; (symbol list-of-expressions)
  | symbol '[' ']'                     ; (symbol)
  | '[' expression ']'                 ; expression
  | '[' cases ':' expression ']'       ; (cond cases (t expression))
                                       ; where cases
                                       ; = ((expression expression) ...)
                                       ; as in "case"
  | lambda                             ; (lambda ...)
  | lambda '[' list-of-expressions ']' ; ((lambda ...) list-of-expressions)
  | lambda '[' ']'                     ; ((lambda ...))

lambda :=
  'lambda' '[' '[' list-of-symbols ']' expression ']'
  ; (lambda (list-of-symbols) expression)
  | 'lambda' '[' '[' ']' expression ']'
  ; (lambda () expression)

concatenation :=
  factor
  | factor '::' concatenation ; (cons factor concatenation)
  | factor '++' concatenation ; (append factor concatenation)

power := concatenation
       | concatenation '^' power ; (expt concatenation power)

term := power
      | term '*' power           ; (* term power)
      | term '/' power           ; (/ term power)
      | term '//' power          ; (quotient term power)
      | term '\\' power          ; (remainder term power)

sum := term
     | sum '+' term             ; (+ sum term)
     | sum '-' term             ; (- sum term)
predicate := sum '=' sum           ; (= sum sum)
           | sum '<>' sum         ; (not (= sum sum))
           | sum '<' sum          ; (< sum sum)
           | sum '>' sum          ; (> sum sum)
           | sum '<=' sum         ; (<= sum sum)
           | sum '>=' sum         ; (>= sum sum)
           | sum

conjunction :=
  predicate
  | conjunction '/\' predicate ; (and conjunction predicate)

disjunction :=
  conjunction
  | disjunction '\/' conjunction ; (or disjunction conjunction)

expression := disjunction

definition :=
  simple-definition
  | simple-definition 'where' definition-list
  ; (define ... (letrec definition-list ...))
  ; where definition-list
  ; = ((symbol (lambda (list-of-symbols) expression)) ...)
  ; | ((symbol (lambda () expression)) ...)
  ; as in "simple-definition"

simple-definition :=
  symbol '[' list-of-symbols ']' ':=' expression
  ; (define (symbol list-of-symbols) expression)
  | symbol '[' ']' ':=' expression
  ; (define (symbol) expression)

definition-list := simple-definition
                 | simple-definition 'and' definition-list

2.7.2. 10.2 实现

我们将直接进入代码.

由于 / 运算符, 需要有理数数学包.

(require '~rmath)

这些类包含用于组成符号和数字的字符:

(define symbol-class '#abcdefghijklmnopqrstuvwxyz_)
(define number-class '#0123456789)

Symbol-p 和 number-p 检查一个字符 (由单字符符号表示) 是否属于特定的类:

(define (symbol-p x) (and (memq x symbol-class) :t))
(define (number-p x) (and (memq x number-class) :t))

10.2.1 词法分析

prefix->infix 解析器 [page 117] 使用符号列表来表示输入程序. 因为 M-表达式可能比几个字符长, 并且可能跨越多行输入, 所以这种表示不适用于 M-表达式.

MEXPRC 将使用可变长度的符号列表, 而不是单字符符号列表. 每个符号可以包含一个或多个标记 (token). 这是 MEXPR 表示法中的一个 M-表达式示例:

'( fact[x] :=
   [x=0-> 1:
    fact[x-1]*x] )

这个列表包含以下符号

fact[x]
:=
[x=0->
1:
fact[x-1]*x]

每个符号至少包含一个标记. Token 只是词素 (lexeme) 的另一个词. 在编译器文本中很常见. 这些是上面列表中包含的单个标记:

fact [ x ]
:=
[ x = 0 ->
1 :
fact [ x - 1 ] * x ]

一个包含一些标记的符号被称为片段 (fragment), 因为它持有输入程序的一个片段. 每个 M-表达式程序都由一个片段序列表示.

MEXPRC 编译器的第一阶段扫描这样一个片段序列, 并将其分解为单个标记. 这个过程称为词法分析 (lexical analysis). 这个阶段的输出是一个标记序列:

(tokenize '(fact[x] := [x=0-> 1: fact[x-1]*x]))
=> '(fact [ x ] := [ x = 0 -> 1 : fact [ x - 1 ] * x ])

当片段在输入流中首次遇到时, 它们会被展开:

(define (explode-on-demand fragment)
  (cond ((atom fragment) (explode fragment))
        (t fragment)))

Extract-class 从片段的前面提取一个匹配字符类的序列.

(define (extract-class fragment class-p)
  (letrec
    ((input
       (explode-on-demand fragment))
     (x-class
       (lambda (input sym)
         (cond ((null input)
                (list (reverse sym) input))
               ((class-p (car input))
                (x-class (cdr input)
                         (cons (car input) sym)))
               (t (list (reverse sym) input))))))
    (x-class input ())))

以下函数从当前片段中提取符号和数字. 像大多数词法分析函数一样, 它们返回一个列表, 其中包含提取的标记和剩余的输入, 两者都以展开形式:

(extract-symbol 'abc+def) => '(#abc #+def)

这些函数是在 extract-class 的基础上实现的:

(define (extract-symbol fragment)
  (extract-class fragment symbol-p))

(define (extract-number fragment)
  (extract-class fragment number-p))

Extract-char 简单地从输入中提取前导字符:

(define (extract-char fragment)
  (let ((input (explode-on-demand fragment)))
    (list (list (car input)) (cdr input))))

extract-alternative 函数从片段的头部提取一个单字符或双字符标记. 如果片段的第二个字符包含在 alt-tails 参数中, 则提取一个双字符标记, 否则提取一个单字符标记. 例如:

(extract-alternative '>=xyz '#>=) => '(#>= #xyz)
(extract-alternative '>-xyz '#>=) => '(#> #-xyz)

该函数用于提取运算符符号.

(define (extract-alternative fragment alt-tails)
  (let ((input (explode-on-demand fragment)))
    (cond ((null (cdr input))
           (extract-char input))
          ((memq (cadr input) alt-tails)
           (list (list (car input) (cadr input))
                 (cddr input)))
          (t (extract-char input)))))

Extract-token 通过将其输入分派给上述函数之一来提取任何类型的标记. 当当前片段的第一个字符无法识别时, 该函数会发出语法错误.

(define (extract-token fragment)
  (let ((input (explode-on-demand fragment)))
    (let ((first (car input)))
      (cond ((eq first '[)
             (extract-char input))
            ((eq first '])
             (extract-char input))
            ((eq first ',)
             (extract-char input))
            ((eq first '%)
             (extract-char input))
            ((eq first ':)
             (extract-alternative input '#:=))
            ((eq first '+)
             (extract-alternative input '#+))
            ((eq first '-)
             (extract-alternative input '#>))
            ((eq first '*)
             (extract-char input))
            ((eq first '=)
             (extract-char input))
            ((eq first '<)
             (extract-alternative input '#<>=))
            ((eq first '>)
             (extract-alternative input '#>=))
            ((eq first '/)
             (extract-alternative input '#/\))
            ((eq first '\)
             (extract-alternative input '#/\))
            ((eq first '^)
             (extract-char input))
            ((symbol-p first)
             (extract-symbol input))
            ((number-p first)
             (extract-number input))
            (t (bottom 'syntax 'error 'at input))))))

这些只是在词法分析期间使用的中间格式成员的更易于理解的名称:

(define frag car)      ; fragment of input
(define rest cdr)      ; rest of input
(define restfrag cadr) ; fragment of rest of input
(define restrest cddr) ; rest of rest of input

next-token 函数从片段列表的第一个片段中提取第一个标记. 如果第一个片段为空, 它会移除它并前进到下一个片段.

(define (next-token source)
  (cond ((null (frag source))
         (cond ((null (rest source)) ())
               (t (let ((head (extract-token (restfrag source))))
                    (cons (implode (frag head))
                          (cons (restfrag head)
                                (restrest source)))))))
        (t (let ((head (extract-token (frag source))))
             (cons (implode (frag head))
                   (cons (restfrag head)
                         (rest source)))))))

tokenize 函数构成了 MEXPR 编译器的扫描器的前端. 扫描器是执行词法分析的编译器部分. Tokenize 接受一个源程序并发出一个单独的标记列表.

(define (tokenize source)
  (letrec
    ((tok (lambda (src tlist)
            (let ((new-state (next-token src)))
              (cond ((null new-state) (reverse tlist))
                    (t (tok (cdr new-state)
                            (cons (car new-state)
                                  tlist))))))))
    (tok source ())))

10.2.2 语法分析与代码合成

在以下代码中, 语法分析和代码合成是交织在一起的. Zenlisp 表达式在执行语法分析时被合成.

解析器是 MEXPRC 编译器的控制实例: 它通过扫描器读取输入, 并通过合成器 (在这种情况下甚至不是一个单独的阶段) 发出代码. 这就是为什么这种方法被称为语法导向编译 (syntax-directed compilation).

编译器的解析阶段接受标记列表形式的输入 (由扫描器生成), 并发出一个 zenlisp 表达式:

(mexpr-compile (f [ x ] := 2 ^ x) => (define (f x) (expt '#2 x))

编译器语法分析阶段的大多数函数处理部分翻译的程序, 形式为

(S-expression token-list)

其中 S-expression 是一个正在构建的 zenlisp 程序, token-list 是输入程序尚未翻译的其余部分. 最初, S-expression 部分为空, token-list 部分包含完整的标记化输入程序. 在编译期间, 数据从 token-list 移动到 S-expression 部分, 当编译成功完成时, token-list 部分为空, S-expression 部分包含一个完整的 zenlisp 表达式.

parse-term 函数, 例如, 解析并合成一个项:

(parse-term '(() #a*b+c)) => '((* a b) '#+c)

最初, 合成的表达式是 (), 输入程序是 '#a*b+c. Parse-term 移除了项 '#a*b 并生成一个包含合成表达式 '(* a b) 和“剩余”'#+c 的程序结构.

Make-prog 组合一个程序结构:

(define (make-prog sexpr tlist) (list sexpr tlist))

这些函数用于访问程序结构的各个部分:

(define s-expr-of car) ; S-expression built so far
(define rest-of cadr)  ; Not yet translated rest of program

输入程序的末尾是否已到达？

(define (end-of p) (null (rest-of p)))

这个函数提供当前的输入标记, 如果输入已耗尽, 则为 ().

(define (first-of-rest p)
  (cond ((end-of p) ())
        (t (caadr p))))

Rest-of-rest 提供移除了第一个标记的输入程序. 它用于前进到下一个输入标记.

(define (rest-of-rest p)
  (cond ((end-of p) ())
        (t (cdadr p))))

Look-ahead 和 rest-of-look-ahead 类似于 first-of-rest 和 rest-of-rest, 但分别产生输入中的第二个标记和跟随第二个标记的其余部分:

(first-of-rest '(() #a+b*c)) => 'a
(rest-of-rest '(() #a+b*c)) => '#+b*c
(look-ahead '(() #a+b*c)) => '+
(rest-of-look-ahead '(() #a+b*c)) => '#b*c

输入中的第二个字符被称为前瞻标记 (look-ahead token). 它用于在第一个标记不明确时确定接下来是哪种类型的输入. 例如, 一个符号名称可能后面跟着一个左括号, 也可能不跟. 当有一个左括号时, 该符号是函数应用 (或定义) 的一部分, 否则它是对一个变量的引用:

'(sym + sym)
'(sym [ arg ])

在这种情况下, 前瞻标记可用于将进一步的分析委托给适当的过程.

(define (look-ahead p)
  (cond ((end-of p) ())
        ((null (rest-of-rest p)) ())
        (t (car (rest-of-rest p)))))
(define (rest-of-look-ahead p)
  (cond ((end-of p) ())
        ((null (rest-of-rest p)) ())
        (t (cdr (rest-of-rest p)))))

提取标记的第一个字符

(define (first-char x) (car (explode x)))

Quoted 引用一个形式.

(define (quoted x) (list 'quote x))

Parse-list 是第一个实际执行一些语法分析的函数. 它接受一个表示字面量列表的 M-表达式, 并以 S-表达式形式返回一个带引号的列表, 例如:

<< a, b, <<c>>, d>> ----> (quote (a b (c) d))

(箭头表示从 M-表达式到 S-表达式的转换.)

执行实际工作的内嵌 plist 函数有四个参数, 含义如下: tls 是输入标记列表, lst 是到目前为止构建的输出列表, skip 用于跳过逗号, top 是一个标志, 指示我们当前是否正在解析顶层列表 (与嵌套列表相对).

该函数递归地解析内嵌列表.

(define (parse-list tlist)
  (letrec
    ((plist
       (lambda (tls skip lst top)
         ; tls = input
         ; skip = skip next token (commas)
         ; lst = output
         ; top = processing top level list
         (cond ((eq (car tls) '>>)
                (cond (top (make-prog (quoted (reverse lst))
                                      (cdr tls)))
                      (t (make-prog (reverse lst)
                                    (cdr tls)))))
               ((eq (car tls) '<<)
                (let ((sublist (plist (cdr tls) :f () :f)))
                  (plist (rest-of sublist)
                         :t
                         (cons (car sublist) lst)
                         top)))
               (skip
                 (cond ((eq (car tls) ',)
                        (plist (cdr tls) :f lst top))
                       (t (bottom ', 'expected 'at tls))))
               (t (plist (cdr tls)
                         :t
                         (cons (car tls) lst)
                         top))))))
    (plist tlist :f () :t)))

以下函数报告意外的输入结束. 这只是一个缩写, 因为意外的 EOT (文本结束) 是一种常见情况.

(define (unexpected-eot)
  (bottom 'unexpected-end-of-input))

parse-actual-args 函数解析一个函数参数列表 (一个表达式列表), 并返回一个等价的 S-表达式列表:

[a+b, c*d] ----> ((+ a b) (* c d))

它用于命名函数和 lambda 函数的应用.

(define (parse-actual-args tlist)
  (letrec
    ((pargs
       (lambda (tls skip lst)
         (cond ((null tls) (unexpected-eot))
               ((eq (car tls) '])
                (make-prog (reverse lst) (cdr tls)))
               (skip
                 (cond ((eq (car tls) ',)
                        (pargs (cdr tls) :f lst))
                       (t (bottom ', 'expected 'at tls))))
               (t (let ((expr (parse-expr tls)))
                    (pargs (rest-of expr)
                           :t
                           (cons (car expr) lst))))))))
    (pargs tlist :f ())))

Parse-formal-args 解析一个函数的形式参数列表 (函数的变量):

[a,b,c] ----> (a b c)

它类似于 parse-actual-args, 但接受一个符号列表而不是一个表达式列表.

(define (parse-formal-args tlist)
  (letrec
    ((pargs
       (lambda (tls skip lst)
         (cond ((null tls) (unexpected-eot))
               ((eq (car tls) '])
                (make-prog (reverse lst) (cdr tls)))
               (skip
                 (cond ((eq (car tls) ',)
                        (pargs (cdr tls) :f lst))
                       (t (bottom ', 'expected 'at tls))))
               ((symbol-p (first-char (car tls)))
                (pargs (cdr tls) :t (cons (car tls) lst)))
               (t (bottom 'symbol 'expected 'at tls))))))
    (pargs tlist :f ())))

Parse-fun-call 解析一个函数应用:

f[a,b,c] ----> (f a b c)

它专门用于解析命名函数的应用.

(define (parse-fun-call program)
  (let ((function (first-of-rest program))
        (args (parse-actual-args (rest-of-look-ahead program))))
    (make-prog (append (list function)
                       (s-expr-of args))
               (rest-of args))))

Parse-lambda-args 解析一个 lambda 函数的形式参数列表, 如果它出现在输入流中. 如果没有参数列表, 则报告错误.

(define (parse-lambda-args program)
  (cond ((eq (first-of-rest program) '[)
         (parse-formal-args (rest-of-rest program)))
        (t (bottom 'argument 'list 'expected 'in 'lambda[]))))

创建一个 lambda 函数.

(define (make-lambda args term)
  (list 'lambda args term))

parse-lambda-app 函数解析一个 lambda 函数的应用:

[a1 ... an] ----> ((lambda ...) a1 ... an)

当进入这个函数时, 一个前导的 lambda 函数已经被解析, 它的代码已经在传递给它的程序结构的 S-表达式部分了:

(parse-lambda-app '((lambda (x) x) #[y]+z)) => '(((lambda (x) x) y) #+z)

Parse-lambda-app 在源程序中的一个 lambda 函数后面跟着一个左括号时被调用.

(define (parse-lambda-app program)
  (let ((args (parse-actual-args (rest-of-rest program))))
    (make-prog (append (list (s-expr-of program))
                       (s-expr-of args))
               (rest-of args))))

Parse-lambda 解析一个 lambda 函数:

lambda[[v1 ... vn] term] ----> (lambda (v1 ... vn) term)

为了方便, 它使用了前瞻标记. 实际上不需要任何前瞻.

(define (parse-lambda program)
  (cond ((neq (look-ahead program) '[)
         (bottom '[ 'expected 'after 'lambda))
        (t (let ((args (parse-lambda-args
                         (make-prog
                           ()
                           (rest-of-look-ahead program)))))
             (let ((term (parse-expr (rest-of args))))
               (cond ((neq (first-of-rest term) '])
                      (bottom 'missing 'closing '] 'in 'lambda[]))
                     (t (make-prog
                          (make-lambda (s-expr-of args)
                                       (s-expr-of term))
                          (rest-of-rest term)))))))))

为 cond 创建一个子句:

(define (make-case pred expr) (list pred expr))

Parse-cases 解析一个条件表达式的 case, 并为 cond 生成一组子句:

a->b: c->d: e ----> ((a b) (c d) (t e))

注意, 该函数只解析 case, 而不解析包含条件 M-表达式的括号.

(define (parse-cases program)
  (letrec
    ((pcases
       (lambda (prog cases)
         (let ((pred (parse-disj (make-prog () prog))))
           (cond
             ((neq (first-of-rest pred) '->)
              (make-prog (cons (make-case 't (s-expr-of pred))
                               cases)
                         (rest-of pred)))
             (t (let ((expr (parse-expr (rest-of-rest pred))))
                  (cond
                    ((eq (first-of-rest expr) ':)
                     (pcases (rest-of-rest expr)
                             (cons (make-case (s-expr-of pred)
                                              (s-expr-of expr))
                                   cases)))
                    (t (bottom ': 'expected 'in 'conditional 'before
                               (rest-of expr)))))))))))
    (let ((case-list (pcases (rest-of program) ())))
      (make-prog (reverse (s-expr-of case-list))
                 (rest-of case-list)))))

Make-cond-expr 从一个 case 列表创建一个 cond 表达式. 当只有一个 case (默认情况) 时, 跳过 cond, 只合成构成该表达式的表达式.

这是一个必要的扩展, 而不仅仅是一个性能优化, 因为 parse-cond-expr (见下文) 利用了这样一个事实: 只有一个默认 case 的条件表达式在语法上等于分组: 详见 parse-cond-expr.

(define (make-cond-expr cases)
  (cond ((null (cdr cases))
         (cadar cases))
        (t (cons 'cond cases))))

Parse-cond-expr 解析一个条件表达式, 并生成一个等价的 cond 表达式:

[p1-> x1: p2-> x2: ... xn] ----> (cond (p1 x1) (p2 x2) ... (t xn))

实际上, 它只是跳过左方括号, 将 case 的分析委托给 parse-cases (见上), 然后确保有一个定界的右方括号.

Parse-cond-expr 处理条件表达式和分组 (因为它们在语法上是等价的):

[pred->expr: expr] ----> (cond (pred expr) (t expr))
[expr]             ----> (cond (t expr)) ----> expr

冗余的 cond 由 make-cond-expr (见上) 移除.

(define (parse-cond-expr program)
  (let ((cond-expr
          (parse-cases
            (make-prog () (rest-of-rest program)))))
    (cond ((neq (first-of-rest cond-expr) '])
           (bottom '] 'expected 'at 'end 'of
                   'conditional 'expression))
          (t (make-prog
               (make-cond-expr (s-expr-of cond-expr))
               (rest-of-rest cond-expr))))))

因为 parse-cond-expr 有两个功能, 它应该有两个反映这些功能的名字:

(define parse-grouped-expr parse-cond-expr)

parse-factor 函数接受 M-表达式的单个因子, 并生成一个等价的 S-表达式. 当程序结构 program 的源部分的开头标记不是一个有效的因子时, 会报告语法错误.

转换在下面的代码中内联.

(define (parse-factor program)
  (let ((first (first-char (first-of-rest program))))
    (cond ((null first)
           (unexpected-eot))
          ; nil ----> ()
          ((eq (first-of-rest program) 'nil)
           (make-prog () (rest-of-rest program)))
          ; true ----> :t
          ((eq (first-of-rest program) 'true)
           (make-prog :t (rest-of-rest program)))
          ; false ----> :f
          ((eq (first-of-rest program) 'false)
           (make-prog :f (rest-of-rest program)))
          ; lambda[[v ...] x] ----> (lambda (v ...) x)
          ; lambda[[v ...] x][a] ----> ((lambda (v ...) x) a)
          ((eq (first-of-rest program) 'lambda)
           (let ((lambda-term (parse-lambda program)))
             (cond ((eq (first-of-rest lambda-term) '[)
                    (parse-lambda-app lambda-term))
                   (t lambda-term))))
          ; symbol ----> symbol
          ; symbol[x ...] ----> (symbol x ...)
          ((symbol-p first)
           (cond ((eq (look-ahead program) '[)
                  (parse-fun-call program))
                 (t (make-prog (first-of-rest program)
                               (rest-of-rest program)))))
          ; number ----> (quote #number)
          ((number-p first)
           (make-prog (quoted
                        (explode
                          (first-of-rest program)))
                      (rest-of-rest program)))
          ; << element, ... >> ----> (quote (element ...))
          ((eq (first-of-rest program) '<<)
           (parse-list (rest-of-rest program)))
          ; %symbol ----> (quote symbol)
          ((eq first '%)
           (cond ((symbol-p (first-char (look-ahead program)))
                  (let ((rhs (parse-factor
                               (make-prog
                                 ()
                                 (rest-of-rest program)))))
                    (make-prog (quoted (s-expr-of rhs))
                               (rest-of rhs))))
                 (t (bottom 'symbol 'expected 'after '%: program))))
          ; [expression] ----> expression
          ((eq first '[)
           (parse-grouped-expr program))
          ; -factor ----> (- factor)
          ((eq first '-)
           (let ((rhs (parse-factor
                        (make-prog
                          ()
                          (rest-of-rest program)))))
             (make-prog (list '- (s-expr-of rhs))
                        (rest-of rhs))))
          (t (bottom 'syntax 'error 'at (rest-of program))))))

parse-binary 函数解析所有类型的左结合二元运算符:

x op y op z ----> (funop (funop x y) z)

该函数期望在 ops 参数中有一个运算符和函数的关联列表, 其中每个键是一个运算符符号, 每个值是实现该运算符的函数的名称. 下面将给出示例.

parent-parser 参数将绑定到一个解析运算符因子的函数. 运算链的每个因子可能包含更高优先级的运算. 这些更高优先级的运算由 parent-parser 处理.

这个函数是 infix->prefix 解析器中引入的 sum 和 term 函数的泛化, 见第 113 页.

(define (parse-binary program ops parent-parser)
  (letrec
    ((lhs (parent-parser program))
     (collect
       (lambda (expr tlist)
         (let ((op (cond ((null tlist) :f)
                         (t (assq (car tlist) ops)))))
           (cond ((null tlist)
                  (make-prog expr ()))
                 (op (let ((next (parent-parser
                                   (make-prog () (cdr tlist)))))
                       (collect (list (cdr op) expr (s-expr-of next))
                                (rest-of next))))
                 (t (make-prog expr tlist)))))))
    (collect (car lhs) (rest-of lhs))))

Parse-binary-r 类似于 parse-binary, 但解析并合成右结合运算符:

x op y op z ----> (funop x (funop y z))

它是 infix->prefix 解析器 [page 113] 中 power 函数的泛化.

(define (parse-binary-r program ops parent-parser)
  (let ((lhs (parent-parser program)))
    (let ((op (cond ((null (rest-of lhs)) :f)
                    (t (assq (first-of-rest lhs) ops)))))
      (cond ((null (rest-of lhs)) lhs)
            (op (let ((rhs (parse-binary-r
                             (make-prog () (rest-of-rest lhs))
                             ops
                             parent-parser)))
                  (list (list (cdr op) (s-expr-of lhs) (s-expr-of rhs))
                        (rest-of rhs))))
            (t lhs)))))

以下函数实现了讨论中缀到前缀转换一节中描述的表达式解析. 每个函数都在 parse-binary 或 parse-binary-r 的基础上实现了一个产生式. 例如, parse-concat 解析连接运算符并执行以下转换:

a::b ----> (cons a b)
a++b ----> (append a b)

这些操作的因子 (a,b) 由 parse-factor 识别.

(define (parse-concat program)
  (parse-binary-r program
                  '((:: . cons)
                    (++ . append))
                  parse-factor))
; x^y ----> (expt x y)
(define (parse-power program)
  (parse-binary-r program
                  '((^ . expt))
                  parse-concat))
; x*y ----> (* x y)
; x/y ----> (* x y)
; x//y ----> (quotient x y)
; x\\y ----> (remainder x y)
(define (parse-term program)
  (parse-binary program
                  '((* . *)
                    (/ . /)
                    (// . quotient)
                    (\\ . remainder))
                  parse-power))
; x+y ----> (+ x y)
; x-y ----> (- x y)
(define (parse-sum program)
  (parse-binary program
                  '((+ . +)
                    (- . -))
                  parse-term))
; x=y ----> (= x y)
; x<>y ----> ((lambda (x y) (not (= x y))) x y)
; x<y ----> (< x y)
; x>y ----> (> x y)
; x<=y ----> (<= x y)
; x>=y ----> (>= x y)
(define (parse-pred program)
  (parse-binary program
                  '((= . =)
                    (<> . (lambda (x y) (not (= x y))))
                    (< . <)
                    (> . >)
                    (<= . <=)
                    (>= . >=))
                  parse-sum))
; x/\y ----> (and x y)
(define (parse-conj program)
  (parse-binary program
                  '((/\ . and))
                  parse-pred))
; x\/y ----> (or x y)
(define (parse-disj program)
  (parse-binary program
                  '((\/ . or))
                  parse-conj))

parse-expr 函数是表达式解析器的前端. 它将表示 M-表达式的标记列表转换为程序结构.

(define (parse-expr tlist)
  (parse-disj (make-prog () tlist)))

Internal-definition 解析 where 子句中的定义. 它返回一个包含被定义函数的名称和主体的列表:

f[a1 ...] := expr ----> (f (lambda (a1 ...) expr))

结果列表具有 letrec 使用的局部定义的形式.

(define (internal-definition program)
  (let ((head (parse-expr (rest-of program))))
    (cond ((eq (first-of-rest head) ':=)
           (let ((term (parse-expr (rest-of-rest head))))
             (make-prog
               (list (car (s-expr-of head))
                     (make-lambda
                       (cdr (s-expr-of head))
                       (s-expr-of term)))
               (rest-of term))))
          (t (bottom ':= 'expected 'at (rest-of program))))))

parse-compound 函数解析复合定义的 where 部分:

where f[x] := expr ----> ((f (lambda (x) expr))
  and g[x] := expr      (g (lambda (x) expr))
      ... ...)

结果列表可用作 letrec 中的环境.

(define (parse-compound program)
  (letrec
    ((compound
       (lambda (prog def-list)
         (let ((defn (internal-definition (make-prog () prog))))
           (cond ((eq (first-of-rest defn) 'and)
                  (compound (rest-of-rest defn)
                            (cons (s-expr-of defn) def-list)))
                 (t (make-prog
                      (reverse (cons (s-expr-of defn) def-list))
                      (rest-of defn))))))))
    (compound program ())))

从一个环境和一个主体创建一个 letrec 表达式:

(define (make-letrec env term)
  (list 'letrec env term))

Parse-definition 解析简单定义以及复合定义. 它返回 define 的应用:

f[x] := expr ----> (define (f x) expr)
f[x] := y    ----> (define (f x)
 where g[x] := z      (letrec ((g (lambda (x) z)))
                         y))

当调用 parse-definition 时, 定义的头部已经被解析, 所以 program 包含一个像 ((f x) (:= expr)) 这样的部分程序. 原因将在下面解释.

(define (parse-definition program)
  (let ((term (parse-expr (rest-of-rest program))))
    (cond ((eq (first-of-rest term) 'where)
           (let ((compound (parse-compound (rest-of-rest term))))
             (make-prog
               (list 'define
                     (s-expr-of program)
                     (make-letrec (s-expr-of compound)
                                  (s-expr-of term)))
               (rest-of compound))))
          (t (make-prog (list 'define
                              (s-expr-of program)
                              (s-expr-of term))
                        (rest-of term))))))

Parse-program 解析一个完整的 M-表达式程序. 每个程序要么是一个表达式, 要么是一个定义, 这引入了一个问题: 两种句子可能共享一个不确定长度的共同前缀:

f [ a1 ... aoo ]
f [ a1 ... aoo ] := expr

所以解析器需要无限的前瞻来决定标记流中包含哪种输入.

这个问题通过假设输入包含一个表达式并解析它来解决. 解析一个表达式后, 下一个输入标记要么是一个定义运算符 (:=), 要么不是. 当它是一个定义运算符时, 部分翻译的程序被传递给 parse-defintion, 它使用到目前为止生成的 S-表达式作为定义的头部.

所以语法中的歧义实际上是在语义层面处理的 (通过重写 S-表达式的含义), 而不是在句法层面. 这在手工制作的编译器中是一种常见的技术.

(define (parse-program tlist)
  (let ((program (parse-expr tlist)))
    (cond ((eq (first-of-rest program) ':=)
           (parse-definition program))
          (t program))))

M-expr-compile 将一个 M-表达式编译成一个 S-表达式并返回它:

(mexpr-compile '(f[x] := x)) => (define (f x) x))

由 parse-program 返回的程序结构的“剩余”部分必须为空, 否则就发生了语法错误.

(define (mexpr-compile source)
  (let ((program (parse-program (tokenize source))))
    (cond ((end-of program)
           (car program))
          (t (bottom 'syntax 'error 'at (rest-of program))))))

M-expr-eval 编译并求值一个 M-表达式:

(define (mexpr-eval source)
  (eval (mexpr-compile source)))

本章讨论的 MEXPRC 版本读取并编译 M-表达式, 但以 S-表达式的形式发出结果. 你能为 MEXPRC 写一个前端, 将其输出翻译回 M-表达式形式吗？例如:

(mexpr '(1/2 ^ 1/2)) => '(1/4)
(mexpr '(%a :: <<b,c>>)) => '(<< a, b, c >>)
...

MEXPRC 用来区分函数应用和函数定义的技巧引入了一个错误. 它允许函数的形式参数列表中有非符号:

(mexpr-compile '(f[a+b, 17] := expr)) => '(define (f #+ab '#17) expr)

你会如何修复这个错误？

2.7.3. 10.3 示例程序

M-表达式 (MEXPR) 程序可以像 zenlisp 程序一样存储在文件中. MEXPR 程序必须 require MEXPRC, 并且源代码应作为参数放在文件中 of mexpr-eval, as the following example illustrates:

(require 'mexprc)
(mexpr-eval '(
              m_fac[x] := [x=0 -> 1: m_fac[x-1] * x]
              ))

这种形式的 MEXPR 程序可以使用 load 加载. mexpr-eval 的应用会在文件加载时自动编译代码. 所以上面的例子可以这样使用 (假设代码存储在文件 m_fac.l 中):

; user input is in italics
(load m_fac)
=> :t
(mexpr-eval '(m_fac[17]))
=> '#355687428096000

10.3.1 附加列表

这是在第 22 页介绍的 append2 函数的 MEXPR 实现:

(require 'mexprc)
(mexpr-eval '(
              m_append[a,b] :=
                r_append[reverse[a], b]
                where
                  r_append[a,b] :=
                    [null[a]
                     -> b:
                     r_append[cdr[a], car[a]::b]]
              ))

不幸的是, 这个函数不接受可变数量的参数. 在 append 的情况下, 这不是太糟糕, 因为

(append a b c d)

翻译成

a ++ b ++ c ++ d

但在其他情况下, 可变参数函数可能很有用. 你能为可变参数 MEXPR 函数设计一种表示法吗？你能通过修改 MEXPRC 来实现它吗？

10.3.2 汉诺塔
你确实知道汉诺塔 (Towers of Hanoi) 的规则, 对吧？如果不知道, 这里有一个简短的描述:

有三根柱子和一些不同直径的圆盘, 如图 8 所示. 最初, 所有的圆盘都堆叠在一根柱子上, 方式是较小的圆盘总是放在较大的圆盘之上. 任务是将所有圆盘移动到另一根柱子 — 但是:
- 一次只能移动一个圆盘;
- 圆盘只能从一根柱子移动到另一根;
- 不能将较大的圆盘放在较小的圆盘之上.
祝你好运!

当然, 作为一个程序员, 你不会想在脑子里解决这个谜题. 你会想以程序的形式找到一个通用的解决方案, 找到解决给定数量圆盘谜题所需的最小移动次数.

在看下面的 MEXPR 程序之前, 随意找一个这样的解决方案. 一旦你理解了谜题是如何解决的, 解决方案就不难了.
```
(require 'mexprc)
(mexpr-eval '(
              m_hanoi[n] :=
                solve[%LEFT, %MIDDLE, %RIGHT, n]
                where
                  solve[from, to, via, n] :=
                    [n=0
                     -> nil:
                     solve[from, via, to, n-1]
                     ++ list[ list[from, to] ]
                     ++ solve[via, to, from, n-1]]
              ))
```
m_hanoi 程序的复杂度是多少？它可以被改进吗？
10.3.3 n 皇后问题
八皇后问题 (eight queens puzzle) 的规则甚至比汉诺塔的规则更简单: 在一个棋盘上放置八个皇后, 使得没有一个皇后可以攻击另一个. 如果你不下棋或者更喜欢一个不那么暴力的描述: 在一个 8x8 的网格中放置八个物体, 使得没有两个物体可以通过水平、垂直或对角线连接.

N 皇后问题 (N queens) 是这个谜题的一个推广, 它使用一个 nxn 的网格而不是一个棋盘. 本节的程序返回给定大小棋盘的第一个解, 例如:
```
(mexpr-eval '(m_queens[4])) => '(#1 #7 #8 #14)
```
解是字段的列表. 字段被枚举而不是给出它们的 x/y 坐标. 上面的解翻译成以下网格 (物体放置在粗体数字上):
```
3  7 11 15
2  6 10 14
1  5  9 13
0  4  8 12
```
这个问题通常使用回溯 (backtracking) 来解决. 在每列的第一行放置一个棋子, 当它与之前放置的棋子冲突时, 尝试下一行. 当一列中没有更多的行时, 算法回溯到前一列, 并将该列中的棋子移动到下一行. 当一个棋子可以成功地放置在最后一列, 或者当它试图回溯到第一列时, 程序完成.

当一个棋子被放置在最后一列时, 算法找到了一个解. 当它试图回溯到第一列时, 对于给定的网格大小不存在解.

显然, 2x2 网格没有解:
```
1 3   1 3   1 3   1 3
0 2   0 2   0 2   0 2
```
同样地, 你可以证明 3x3 网格没有解, 但已经有 27 种可能的配置需要测试. 更大的网格最好由程序来检查. 这里是:
```
(require 'mexprc)
(mexpr-eval '(
              m_queens[size] :=
                n_queens[0, 0, nil]
                where n_queens[q, c, b] :=
                  [c = size
                   -> reverse[b]:
                   column[q] <> c
                   -> [null[b]
                       -> nil:
                       n_queens[car[b]+1, c-1, cdr[b]]]:
                   safe_place[q, b]
                   -> n_queens[next_column[q], c+1, q::b]:
                   n_queens[q+1, c, b]]

                  and column[x] := x // size

                  and row[x] := x \\ size

                  and safe_place[x,b] :=
                    [null[b]
                     -> true:
                     connected[car[b], x]
                     -> false:
                     safe_place[x, cdr[b]]]

                  and connected[x,y] :=
                    common_h_v[x,y] \/ common_dia[x,y]

                  and common_h_v[x,y] :=
                    row[x] = row[y] \/ column[x] = column[y]

                  and common_dia[x,y] :=
                    abs[column[x]-column[y]] = abs[row[x]-row[y]]

                  and next_column[q] := [q+size] // size * size
              ))
```
这个程序只打印给定网格大小的第一个解. 你能修改它以打印所有解吗？

m_queens 的最坏情况复杂度是多少？它的平均复杂度是多少？

你认为对于所有大于 3x3 的网格大小都存在解吗？

2.8. 11. 另一个 micro kanren

amk (Another Micro Kanren) 包在 zenlisp 中嵌入了声明式逻辑编程. 它基于 Daniel P. Friedman 等人在“The Reasoned Schemer” ¹⁹ 中提出的思想. 该代码也受到了 Oleg Kiselyov 的“Sokuza Mini-Kanren”实现的启发.

2.8.1. 11.1 介绍

11.1.1 函数与目标
在函数式编程中, 函数被组合起来形成程序. 例如, zenlisp 的 append 函数连接列表:
```
(append '#orange '#-juice) => '#orange-juice
```
逻辑编程的基本构件被称为目标 (goals). 目标是一个将知识映射到知识的函数:
```
(run* () (appendo '#orange '#-juice '#orange-juice)) => '(())
```
run* 的应用被称为查询 (query). Run* 是 zenlisp 和 amk 之间的接口. run* 的结果被称为相应查询的答案 (answer).

上面查询中使用的目标是 append0 [page 177].

形式为 '(()) 的答案意味着“成功”. 在上面的例子中, 这意味着 '#orange-juice 确实等于 '#orange 和 '#-juice 的连接.

一个返回肯定答案的目标被称为成功 (succeed).
```
(run* () (appendo '#orange '#-juice '#fruit-salad)) => ()
```
不成功, 因为 '#fruit-salad 不能通过将 '#orange 附加到 '#-juice 来构造.

一个不成功的目标被称为失败 (fail). 失败由 () 表示. 当目标的一个或多个参数被变量替换时, 目标会尝试推断 (infer) 这些变量的值.

逻辑变量由 var 函数创建:
```
(define vq (var 'q))
```
目标的任何参数都可以是变量:
```
(run* vq (appendo '#orange '#-juice vq)) => '(#orange-juice)
(run* vq (appendo '#orange vq '#orange-juice)) => '(#-juice)
(run* vq (appendo vq '#-juice '#orange-juice)) => '(#orange)
```
在这些示例查询中, run* 被告知我们对 vq 的值感兴趣. 它运行给定的目标, 然后返回 vq 的一个或多个值, 而不仅仅是成功或失败.

目标是非确定性的 (non-deterministic), 所以一个查询可能会返回多个答案:
```
(run* vq (let ((dont-care (var 'dont-care)))
           (appendo dont-care vq '#abcd)))
=> '(#abcd #bcd #cd #d ())
```
这个查询返回所有当附加到不感兴趣的东西上时给出 '#abcd 的值. 换句话说, 它返回 '#abcd 的所有后缀.

随后, 以下查询返回所有前缀:
```
(run* vq (let ((dont-care (var 'dont-care)))
           (appendo vq dont-care '#abcd)))
=> '(() #a #ab #abc #abcd)
```
你认为以下查询的答案是什么？
```
(run* vq (let ((x (var 'x))
               (y (var 'y)))
           (appendo x y vq)))
```
它有答案吗？

答案: 这个查询没有答案, 因为有无限多的组合可以用来形成一个具有不特定前缀和后缀的连接. 所以 append0 永远不会停止为其变量生成值的组合.
11.1.2 合一
合一 (Unification) 是构成每个逻辑编程系统核心的算法. “合一”目标写作 ==. 查询
```
(run* vq (== x y))
```
意味着“将 x 与 y 合一”. 这个查询的答案取决于 x 和 y 的值:
```
(run* vq (== 'pizza 'pizza)) => '(())
(run* vq (== 'cheese 'pizza)) => ()
(run* vq (== vq vq)) => '(())
(run* vq (== 'cheese vq)) => '(cheese)
```
当两个原子传递给 == 时, 如果原子相等, 它就成功.

当一个变量传递给 == 时, 该变量被绑定 (bound) 到另一个参数:
```
(run* vq (== vq 'cheese)) => '(cheese)
(run* vq (== 'cheese vq)) => '(cheese)
```
参数的顺序不重要.

当两个变量被合一时, 这两个变量保证总是绑定到相同的值:
```
(run* vq (let ((vx (var 'x)))
           (== vq vx)))
```
使得 vq 和 vx 绑定到相同的值. 稍后将一个值绑定到其中一个会自动将该值绑定到它们两个.

非原子参数通过首先合一它们的 car 部分, 然后合一它们的 cdr 部分来递归地合一:
```
(run* vq (== '(x (y) z) '(x (y) z))) => '(())
(run* vq (== '(x (y) z) '(x (X) z))) => ()
(run* vq (== vq '(x (y) z))) => '((x #y z))
```
即使变量深埋在列表中, 推理也能工作:
```
(run* vq (== (list 'x vq 'z) '(x #y z))) => '(#y)
```
因为 '#y 是使目标成功的唯一 vq 值, 所以该值被绑定到 vq.

这是如何工作的？
- 'x 与 'x 合一;
- vq 与 '#y 合一 (将 vq 绑定到 '#y);
- 'z 与 'z 合一.
每次合一都可能通过将变量绑定到值或合一两个变量来扩展系统的“知识”.

当合一列表时, 列表的 cdr 部分是在合一其 car 部分期间获得的知识的上下文中合一的:
```
(run* vq (== '( pizza fruit-salad)
             (list vq vq ))) => ()
```
这个合一不能成功, 因为 vq 首先被绑定到 'pizza, 然后同一个变量被合一到 'fruit-salad. 当 vq 与 'pizza 合一时, vq 是新鲜的 (fresh). 如果一个变量尚未绑定到任何值, 那么它就是新鲜的.

只有新鲜的变量才能被绑定到值.

当一个形式与一个绑定的变量合一时, 它与该变量的值合一. 因此
```
(run* vq (== '(pizza fruit-salad) (list vq vq))) => ()
```
等价于
```
(run* vq (== '(pizza fruit-salad) (list vq 'pizza))) => ()
```
以下查询成功, 因为没有引入矛盾:
```
(run* vq (== '(pizza pizza) (list vq vq))) => '(pizza)
```
首先 vq 与 'pizza 合一, 然后 vq 的值 (此时是 'pizza) 与 'pizza 合一.

绑定的变量仍然可以与新鲜的变量合一:
```
(run* vq (let ((vx (var 'x)))
           (== (list 'pizza vq)
               (list vx vx)))) => '(pizza)
```
这里 vx 与 'pizza 合一, 然后新鲜的变量 vq 与 vx 合一, 将 vq 和 vx 绑定到相同的值.

再次, 合一的顺序不重要:
```
(run* vq (let ((vx (var 'x)))
           (== (list vq 'pizza)
               (list vx vx)))) => '(pizza)
```
11.1.3 逻辑运算符
any 目标如果其至少一个子目标成功, 则成功:
```
(run* vq (any (== vq 'pizza)
              (== 'orange 'juice)
              (== 'yes 'no)))
=> '(pizza)
```
在这个例子中, 三个子目标中的一个成功并对答案做出贡献.

因为 any 如果至少一个子目标成功就成功, 所以如果没有给出子目标, 它就失败:
```
(run* () (any)) => ()
```
any 的多个子目标可能将同一个变量与不同的形式合一, 从而给出一个非确定性的答案:
```
(run* vq (any (== vq 'apple)
              (== vq 'orange)
              (== vq 'banana)))
=> '(apple orange banana)
```
没有引入矛盾. Vq 被绑定到这三个值中的每一个.

any 目标实现了运行其子目标所获得的知识的并集 (union):
```
(run* vq (any fail
              (== vq 'fruit-salad)
              fail))
=> '(fruit-salad)
```
即使它的一些子目标失败, 它也成功. 因此, 它等同于逻辑或.

Fail 是一个总是失败的目标.

all 目标是 any 的表亲, 它实现了逻辑与:
```
(run* vq (all (== vq 'apple)
              (== 'orange 'orange)
              succeed))
=> '(apple)
```
Succeed 是一个总是成功的目标.

All 只有在它的所有子目标都成功时才成功, 但它做的还不止这些.

All 通过移除其答案中的任何矛盾来形成运行其子目标所收集的知识的交集:
```
(run* vq (all (== vq 'apple)
              (== vq 'orange)
              (== vq 'banana))) => ()
```
这个查询失败, 因为 vq 不能同时被绑定到 'apple, 'orange 和 'banana.

all 的效果最好与 any 结合起来说明:
```
(run* vq (all (any (== vq 'orange)
                   (== vq 'pizza))
              (any (== vq 'apple)
                   (== vq 'orange))))
=> '(orange)
```
第一个 any 将 vq 绑定到 'orange 或 'pizza, 第二个将它绑定到 'apple 或 'orange. All 通过移除矛盾 vq='pizza 和 vq='apple 来形成这个知识的交集. Vq='orange 不是矛盾, 因为它出现在 all 的两个子目标中.

顺便说一句: 如果 all 的至少一个子目标失败, all 就会失败. 因此, 如果没有目标传递给它, 它就成功:
```
(run* () (all)) => '(())
```
11.1.4 参数化目标
参数化目标 (parameterized goal) 是一个返回目标的函数:
```
(define (conso a d p) (== (cons a d) p))
```
conso 的应用求值为一个目标, 所以 cons0 可以用来在查询中形成目标:
```
(run* vq (conso 'heads 'tails vq)) => '((heads . tails))
```
在散文中, conso 写为 cons0. 目标名称末尾的“o”是分开念的 (例如“cons-oh”).

显然, cons0 实现了一个类似于 cons 函数的东西.

然而, cons0 可以做的更多:
```
(run* vq (conso 'heads vq '(heads . tails))) => '(tails)
(run* vq (conso vq 'tails '(heads . tails))) => '(heads)
```
所以 conso0 可以用来定义另外两个有用的目标:
```
(define (caro p a) (conso a (_) p))
```
Car0 类似于 zenlisp 的 car 函数, cdr0 类似于它的 cdr 函数:
```
(define (cdro p d) (conso (_) d p))
```
像 PROLOG 的 _ 变量一样, 表达式 (_) 表示一个不感兴趣的值.

当 car0 和 cdr0 的第二个参数是一个变量时, 它们类似于 car 和 cdr:
```
(run* vq (caro '(x . y) vq)) => '(x)
(run* vq (cdro '(x . y) vq)) => '(y)
```
像 cons0 一样, car0 和 cdr0 可以比它们的 zenlisp 对应物做的更多:
```
(run* vq (caro vq 'x)) => '((x . _,0))
(run* vq (cdro vq 'y)) => '((_,0 . y))
```
查询
```
(run* vq (caro vq 'x))
```
问: “'x' 的 car 部分是什么？” 答案是 “任何具有 'x' 的 car 部分和不重要 cdr 部分的对.”

聪明, 不是吗？
11.1.5 具体化
形式为 _,n 的原子, 其中 n 是一个唯一的数字, 每当答案否则会包含新鲜变量时出现:
```
(run* vq (let ((vx (var 'x))
               (vy (var 'y))
               (vz (var 'z)))
           (== vq (list vx vy vz))))
=> '((_,0 _,1 _,2))
```
在本文的其余部分, _,n 可以写成 _n.

_0, _1, 等被称为具体化变量 (reified variables).

用具体化的名称替换新鲜变量被称为具体化 (reification). 它用一个唯一的“项目” (res 是拉丁语“item”的词) 替换每个新鲜变量.
11.1.6 递归
这是一个递归的 zenlisp 谓词:
```
(define (mem-p x l)
  (cond ((null l) :f)
        ((eq x (car l)) :t)
        (t (mem-p x (cdr l)))))
```
Mem-p 测试 l 是否包含 x:
```
(mem-p 'c '#abcdef) => :t
(mem-p 'x '#abcdef) => :f
```
在 amk 中你不能写像 (eq x (car l)) 这样的代码, 因为

在逻辑编程中, 没有函数复合.

每个目标的参数必须要么是一个数据, 要么是一个变量. 只有 any 和 all 有子目标:
```
(define (memo x l)
  (let ((va (var 'a))
        (vd (var 'd)))
    (any (all (caro l va)
              (eqo x va))
         (all (cdro l vd)
              (lambda (s)
                ((memo x vd) s))))))
```
这里有一些观察:
- 一个包含一个或多个 all 目标的 any 是 cond 的逻辑编程等价物;
- 每次进入 mem0 时, 都会创建一个新的 va 和 vd;
- Mem0 似乎不检查 l 是否是 ();
- 递归情况使用“eta 转换”来避免早期递归 (见下文).
mem0 工作吗？是的:
```
(run* () (memo 'c '#abcdef)) => '(())
(run* () (memo 'x '#abcdef)) => ()
```
它是如何工作的？

第一个 all 将 l 的 car 部分与 va 合一. 如果 l=(), all 失败.

Eq0 是 == 的同义词.

如果 va (现在是 (car l) 的别名) 可以与 x 合一, 这个 any 的分支就成功了.

如果 l 是 (), 这两个目标都失败:
```
(caro l va) => ()
(cdro l vd) => ()
```
所以整个 mem0 失败了. 不需要显式地测试 l=().

mem0 的第二个 all 将 vd 与 l 的 cdr 部分合一, 然后递归.

因为 any 和 all 是普通的 zenlisp 函数, 如果 mem0 的应用没有被 eta 展开保护, 递归将在运行 all 之前发生.

Eta 展开将一个 lambda 函数包装在另一个函数周围 (而 eta 归约移除了那个“包装器”):
```
(memo x vd) <-------> (lambda (s) ((memo x vd) s))
                eta
```
两种转换都保持了原始函数的含义, 除了它的归约时间: (memo x vd) 会立即归约 (提供一个目标), 而在
```
(lambda (s) ((memo x vd) s))
```
中, 目标只有在包含它的 lambda 函数被应用到一个值时才被创建. Eta 展开有效地实现了“传名调用”语义.

所有递归情况都必须使用 eta 展开来保护.
11.1.7 将谓词转换为目标
谓词是返回真值的函数.

每个目标都是一个谓词, 因为它要么失败要么成功.

将谓词转换为目标涉及五个步骤: c1. 分解函数复合; c2. 用参数化目标替换函数; c3. 用 any 替换 cond 及其子句用 all; c4. 移除使谓词失败的子目标; c5. 使用 eta 展开保护递归情况.

Mem-p [page 171] 转换如下:
```
((eq x (car l)) :t)
```
通过 c1, c2, c3 变成
```
(let ((va (var 'a)))
  (all (caro l va)
       (eqo x va)))
```
和
```
(t (mem-p x (cdr l)))
```
通过 c1, c2, c3, c5 变成
```
(let ((vd (var 'd)))
  (all (cdro l vd)
       (lambda (s)
         ((memo x vd) s))))
```
最后
```
((null l) :f)
```
被移除 (通过 c4), cond 被 any 替换 (通过 c3).

在 mem0 的原始定义中, (let ((va …))) 和 (let ((vd …))) 被组合并移到 any 之外.

顺便说一句, mem0 中 eq0 的应用是多余的, 因为 car0 本身可以确保 x 是 l 的 car 部分. 所以 mem0 可以显著简化:
```
(define (memo x l)
  (let ((vt (var 't)))
    (any (caro l x)
         (all (cdro l vt)
              (lambda (s)
                ((memo x vt) s))))))
```
11.1.8 将函数转换为目标
Memq 类似于 mem-p:
```
(define (memq x l)
  (cond ((null l) :f)
        ((eq x (car l)) l)
        (t (memq x (cdr l)))))
```
它不是在成功的情况下只返回 :t, 而是返回 l 的第一个其 car 部分是 x 的子列表:
```
(memq 'orange '(apple orange banana)) => '(orange banana)
```
函数以与谓词相同的方式转换为目标, 但有一个额外的规则: c6. 添加一个额外的参数以与结果合一.

Memq0 类似于 mem0, 但它有一个额外的参数 r 用于结果, 以及一个将结果与 r 合一的额外目标:
```
(define (memqo x l r)
  (let ((vt (var 't)))
    (any (all (caro l x)
              (== l r))
         (all (cdro l vt)
              (lambda (s)
                ((memqo x vt r) s))))))
```
像 memq 一样, memq0 可以被查询以提供 l 的第一个其头部是 x 的子列表:
```
(run* vq (memqo 'orange '(apple orange banana) vq))
=> '((orange banana))
```
Memq0 甚至提供 l 的所有以 x 开头的子列表:
```
(run* vq (memqo 'b '#abababc vq))
=> '(#bababc #babc #bc)
```
如果你只对第一个感兴趣, 取答案的 car 部分.

Memq0 可以用来实现恒等函数:
```
(run* vq (memqo vq '(orange juice) (_)))
=> '(orange juice)
```
这是如何工作的？

这里问的问题是“vq 应该与什么合一才能使 (memqo vq '(orange juice) (_)) 成功？”

memq0 中的 car0 将 vq (与 x 合一) 与 'orange 合一, 因为 vq 是新鲜的, 它成功了. 第二种情况也成功. 它将 l 绑定到 '(juice) 并重试目标. 在这个分支中, vq 仍然是新鲜的.

memq0 中的 car0 将 vq 与 'juice 合一, 因为 vq 是新鲜的, 它成功了.

第二种情况也成功. 它将 l 绑定到 () 并重试目标. 在这个分支中, vq 仍然是新鲜的.

(memqo vq () (_)) 失败, 因为无论是 car0 还是 cdr0 都不能在 l=() 的情况下成功.

Any 形成了 vq='orange 和 vq='juice 的并集, 这就是查询的答案.
11.1.9 cond 与 any
LISP 的 cond 伪函数顺序地测试其子句的谓词, 并返回与第一个真谓词关联的表达式的范式:
```
(cond (t 'bread)
      (:f 'with)
      (t 'butter)) => 'bread
```
尽管子句 (t 'butter) 也有一个真谓词, 上面的 cond 永远不会返回 'butter.

any 和 all 的组合可以用来形成 cond 的逻辑编程等价物:
```
(run* vq (any (all succeed (== vq 'bread))
              (all fail    (== vq 'with))
              (all succeed (== vq 'butter))))
=> '(bread butter)
```
Any 替换 cond, all 引入每个单独的 case.

然而, 与 cond 不同, 这个构造返回所有成功 case 的值.

虽然 cond 在成功的情况下忽略了剩余的子句, any 会一直尝试直到用完所有子目标.

这就是为什么 memq0 [page 174] 返回所有以给定形式开头的子列表的原因:
```
(run* vq (memqo 'b '#abababc vq)) => '(#bababc #babc #bc)
```
这是如何工作的:

当 l 的头部不等于 'b 时, memq0 的第一个子目标失败, 所以答案中没有添加任何内容.

当 l 的头部等于 'b 时, any 的第一个子目标成功, 所以 l 被添加到答案中.

无论哪种情况, 都会尝试第二个目标. 只要 l 可以被分解, 它就成功. 当到达列表 l 的末尾时, 它失败. 当第二个目标成功时, 整个 any 会在 l 的 cdr 部分上被尝试, 这可能会向答案中添加更多的子列表.

当 memq0 中 case 的顺序颠倒时会发生什么？
```
(define (rmemqo x l r)
  (let ((vt (var 't)))
    (any (all (cdro l vt)
              (lambda (s)
                ((rmemqo x vt r) s)))
         (all (caro l x)
              (== l r)))))
```
因为 any 一直尝试直到用完目标, 所以 rmemq0 确实返回所有匹配的子列表, 就像 memq0 一样. 然而…
```
(run* vq (memqo 'b '#abababc vq)) => '(#bababc #babc #bc)
(run* vq (rmemqo 'b '#abababc vq)) => '(#bc #babc #bababc)
```
因为 rmemq0 首先递归, 然后检查匹配的子列表, 它的答案列出了最后一个匹配的子列表.

颠倒 memq0 的目标使其以相反的顺序返回其结果.

虽然 memq0 可以实现恒等函数, 但 rmemq0 可以实现一个反转列表的函数:
```
(run* vq (memqo vq '(ice water) (_))) => '(ice water)
(run* vq (rmemqo vq '(ice water) (_))) => '(water ice)
```
11.1.10 头等变量
逻辑变量是头等 (first class) 值.

当一个绑定的逻辑变量被用作目标的参数时, 该变量的值被传递给目标:
```
(run* vq (let ((vx (var 'vx)))
           (all (== vx 'piece-of-cake)
                (== vq vx))))
=> '(piece-of-cake)
```
当一个新鲜的变量被用作目标的参数时, 变量本身被传递给该目标:
```
(run* vq (let ((vx (var 'x)))
           (== vq vx)))
=> '(_,0)
```
因为变量 vx 是新鲜的, 它在运行查询后被解释器具体化, 得到 _0.

变量甚至可以是复合数据结构的一部分:
```
(run* vq (let ((vx (var 'x)))
           (conso 'heads vx vq)))
=> '((heads . _,0))
```
稍后合一作为数据结构一部分的变量会导致数据结构的变量部分被“迟来地”“填充”:
```
(run* vq (let ((vx (var 'x)))
           (all (conso 'heads vx vq)
                (== vx 'tails))))
=> '((heads . tails))
```
append0 目标利用了这一事实:
```
(define (appendo x y r)
  (any (all (== x ())
            (== y r))
       (let ((vh (var 'h))
             (vt (var 't))
             (vtr (var 'tr)))
         (all (conso vh vt x)
              (conso vh vtr r)
              (lambda (s)
                ((appendo vt y vtr) s))))))
```
以下查询是如何处理的？
```
(run* vq (appendo '#ab '#cd vq))
```
在其递归情况下, append0 首先将 x='#ab 分解为其头部 vh='a 和尾部 vt='#b:
```
(conso vh vt x)
```
下一个子目标指出, 头部 vh 与 vtr (结果的尾部) 相 cons 得到 append0 的结果:
```
(conso vh vtr r)
```
因为 vtr 此时是新鲜的, r 被绑定到一个包含变量的结构: \[ r_0 = (\text{cons 'a } vtr_0) \] 这里 Vtr 和 r 被称为 $vtr_0$ 和 $r_0$, 因为它们是这些变量的第一个实例.

当目标递归时, $vtr_0$ 被传递给 append0 代替 r:
```
(appendo '#b '#cd vtr0)
```
Append0 创建了 vtr 和 r 的新实例 (称为 $vtr_1$ 和 $r_1$).

此时, $r_1$ 和 $vtr_0$ 可以被认为是同一个变量, 所以
```
(conso vh vtr1 r1)
```
导致 \[ r_1 = vtr_0 = (\text{cons 'b } vtr_1) \] 并且 \[ r_0 = (\text{cons 'a } vtr_0) = (\text{cons 'a } (\text{cons 'b } vtr_1)) \] 当 append0 最后一次递归时, $vtr_1$ 被传递给目标代替 r, 并创建了实例 $r_2$:
```
(appendo () '#cd vtr1)
```
因为 x=(), 所以处理平凡情况的子目标被运行:
```
(== y r2)
```
因为 $r_2$ 和 $vtr_1$ 是同一个变量, \[ r_2 = vtr_1 = \text{'#cd} \] \[ r_1 = vtr_0 = (\text{cons 'b } vtr_1) = (\text{cons 'b '#cd}) \] \[ r_0 = (\text{cons 'a } vtr_0) = (\text{cons 'a } (\text{cons 'b } vtr_1)) = (\text{cons 'a } (\text{cons 'b '#cd})) \]

11.1.11 头等目标

像 LISP 函数一样, 目标是头等值.

filter0 目标利用了这一事实:

(define (filtero p l r)
  (let ((va (var 'a))
        (vd (var 'd)))
    (any (all (caro l va)
              (p va)
              (== va r))
         (all (cdro l vd)
              (lambda (s)
                ((filtero p vd r) s))))))

Filter0 从列表中提取具有给定属性的所有成员.

该属性由作为参数传递给 filter0 的目标 p 描述.

(run* vq (filtero pairo '(a b (c . d) e (f . g)) vq))
=> '((c . d) (f . g))

Pair0 定义如下:

(define (pairo x) (conso (_) (_) x))

因为参数化目标是普通函数, 所以不需要发明新的函数名. Lambda 就可以:

(run* vq (filtero (lambda (x) (conso (_) (_) x))
                  '(a b (c . d) e (f . g)) vq))
=> '((c . d) (f . g))

11.1.12 否定
neg 目标如果其子目标失败则成功, 如果其子目标成功则失败:
```
(run* () (neg fail)) => '(())
(run* () (neg succeed)) => ()
```
Neg 从不贡献任何知识:

当其子目标成功时, neg 本身失败, 从而删除其子目标收集的所有知识.

当其子目标失败时, 没有知识可以添加.

然而, neg 并不像看起来那么直接:
```
(define (nullo x) (eqo () x))
(run* vq (neg (nullo vq)))
```
null0 目标测试其参数是否为 ().

“不等于 () 的是什么？”这个问题的答案应该是什么？

Neg 使用一种称为“封闭世界假设”的方法来回答这个问题, 该方法说“不能被证明为真的东西必须是假的”.

所以上面问题的答案是“什么都不是”. 因为 vq 的值是未知的, neg 不能证明它不等于 (), 于是失败:
```
(run* vq (neg (nullo vq))) => ()
```
从技术上讲, 它的工作方式是这样的:

Vq 是新鲜的, 所以 null0 将它与 () 合一并成功. 因为 null0 成功, 所以 neg 必须失败.

这种方法有其后果:
```
(run* vq                                    (run* vq
  (all (any (== vq 'orange)                   (all (neg (== vq 'pizza))
            (== vq 'pizza)                        (any (== vq 'orange)
            (== vq 'ice-cream))                      (== vq 'pizza)
       (neg (== vq 'pizza))))                      (== vq 'ice-cream))))
=> '(orange ice-cream)                      => ()
```
根据其上下文, neg 有不同的功能.

在右边的例子中, 它使得整个查询失败, 因为新鲜的变量 vq 可以与 'pizza 合一.

在左边的例子中, vq 已经有一些值, 它消除了 vq 和 'pizza 的合一.

因此

应谨慎使用否定.
11.1.13 切割
memq0 目标 [page 174] 返回所有其头部匹配给定形式的子列表:
```
(run* vq (memqo 'b '#abababc vq)) => '(#bababc #babc #bc)
```
对于你真的, 真的只对第一个匹配感兴趣的情况, 有一种称为切割 (cutting) 的技术.

它由 one 目标实现:
```
(run* vq (one fail
              (== vq 'apple)
              (== vq 'pie)))
=> '(apple)
```
一旦 one 的一个子目标成功, one 本身立即成功并“切断”其余的子目标.

one 的名称表明其子目标最多只有一个可以成功.

使用 one, 可以实现 memq0 的一个变体, 它在第一个匹配时成功:
```
(define (firsto x l r)
  (let ((vd (var 'd)))
    (one (all (caro l x)
              (== r l))
         (all (cdro l vd)
              (lambda (s)
                ((firsto x vd r) s))))))
```
memq0 和 first0 之间的唯一区别是 first0 使用 one 代替 any.

First0 在第一个 case 成功时立即切断递归 case:
```
(run* vq (firsto 'b '#abababc vq)) => '(#bababc)
```
所以 one 更像 cond 而不是 any.

然而, one 抑制了回溯, 这是逻辑编程系统最有趣的特性之一.

这是另一个谓词:
```
(define (juiceo x)
  (let ((vt (var 't)))
    (all (cdro x vt)
         (caro vt 'juice))))
```
Juice0 成功, 如果其参数是一个列表, 其第二个元素等于 'juice, 例如:
```
(run* () (juiceo '(orange juice))) => '(())
(run* () (juiceo '(cherry juice))) => '(())
(run* () (juiceo '(apply pie ))) => ()
```
给定 juice0 谓词, memq0 可用于在菜单上定位你最喜欢的果汁:
```
(define menu '(apple pie orange pie cherry pie
               apple juice orange juice cherry juice))
(run* vq (all (memqo 'orange menu vq)
              (juiceo vq)))
=> '((orange juice cherry juice))
```
当 memq0 找到以 'orange 开头的子列表, 紧挨着 'pie 前面时, juice0 失败, 并启动回溯.

Memq0 然后定位下一个 'orange 的出现, 这次 juice0 成功.

使用 first0 抑制了回溯, 所以我们最喜欢的果汁永远也找不到了:
```
(run* vq (all (firsto 'orange menu vq)
              (juiceo vq)))
=> ()
```
因此

应谨慎使用切割.

2.8.2. 11.2 一个逻辑谜题

斑马谜题 (Zebra Puzzle) 是一个著名的逻辑谜题.

其定义如下:

五个不同国籍的人住在一排五栋房子里.
房子被漆成不同的颜色.
这些人喜欢不同的饮料和香烟品牌.
所有人都养着不同的宠物.
英国人住在红色的房子里.
西班牙人养了一只狗.
绿色的房子里喝咖啡.
乌克兰人喝茶.
绿色的房子紧挨着象牙色房子的右边.
老金牌 (Old Gold) 吸烟者养了蜗牛.
黄色的房子里抽库尔 (Kools) 烟.
中间的房子里喝牛奶.
挪威人住在最左边的第一栋房子里.
切斯特菲尔德 (Chesterfield) 吸烟者住在狐狸主人旁边.
库尔烟是在马主人旁边的房子里抽的.
幸运罢工 (Lucky Strike) 吸烟者喝橙汁.
日本人抽议会 (Parliaments) 烟.
挪威人住在蓝色房子旁边.

谁养了斑马？

要解决这个谜题, 需要回答两个问题:

如何表示数据？
如何添加事实？

五个属性与每栋房子相关联, 所以这排房子可以由一个包含 5-元组的列表表示, 像这样:

(nation cigarette drink pet color)

已知的事实用符号表示, 未知的用变量表示. 事实“西班牙人养了一只狗”看起来会是这样:

(list 'spaniard (var 'cigarette) (var 'drink) 'dog (var 'color))

事实的添加通过一个只有两个属性和两栋房子的谜题的简化变体来解释:

(list (list (var 'person) (var 'drink))
      (list (var 'person) (var 'drink)))

一栋房子里住着一个瑞典人.
一栋房子里有一个喝茶的人.
一栋房子里住着一个喝咖啡的日本人.
喝茶的人住在左边的房子里.

应用第一个事实会产生以下选项 (变量以斜体显示):

'( ((Swede drink) house)
   (house (Swede drink)) )

这意味着瑞典人 (其饮料未知) 可以住在第一栋或第二栋房子里.

添加第二个事实会产生更多的选项:

'( ((Swede Tea) house)
   ((Swede drink) (person Tea))
   ((person Tea) (Swede drink))
   (house (Swede Tea)) )

应用事实的关键是合一. 事实

(list 'Swede (var 'drink))

可以与任何新鲜变量 (如 h, 表示 house) 合一:

(define h (var 'h))
(run* h (== h (list 'Swede (var 'drink))))
=> '((swede _,0))

要创建所有可能的结果, 必须将该事实应用于两栋房子中的每一栋:

(define fact (list 'Swede (var 'drink)))
(run* h (let ((h1 (var 'house1))
              (h2 (var 'house2)))
          (all (== h (list h1 h2))
               (any (== fact h1)
                    (== fact h2)))))
=> '(((swede _,0) _,1)
     (_,0 (swede _,1)))

记住: 具体化的变量, 如 _0 和 _1, 表示未知和/或不感兴趣的东西.

在上面的答案中, _0 表示第一个结果中未知的饮料和第二个结果中未知的房子. _1 表示第一个结果中未知的房子和第二个结果中未知的饮料.

每个新的事实都必须与到目前为止产生的所有结果合一.

一个自动将一个事实与所有找到的结果合一的目标会很有帮助. mem0 目标, 在本章前面 [page 173] 定义, 可以做到这一点.

Mem0 尝试将一个给定的形式与列表的每个成员合一. 将“形式”替换为“事实”, 将“列表”替换为“结果”, 我们就可以开始了:

(run* h (all (== h (list (var 'h1)
                         (var 'h2)))
             (memo (list 'Swede (var 'drink)) h)
             (memo (list (var 'person) 'Tea) h)))
=> '(((swede tea) _,0)
     ((swede _,0) (_,1 tea))
     ((_,0 tea) (swede _,1))
     (_,0 (swede tea)))

此时, 查询是欠定的; 已知的事实不足以告诉我们瑞典人住在哪里或者他是否喝茶.

通过添加第三个事实, 一些结果被消除了:

(run* h (all (== h (list (var 'house1)
                         (var 'house2)))
             (memo (list 'Swede (var 'drink)) h)
             (memo (list (var 'person) 'Tea) h)
             (memo (list 'Japanese 'Coffee) h)))
=> '(((swede tea) (japanese coffee))
     ((japanese coffee) (swede tea)))

查询仍然是欠定的, 但因为第三个事实与另一个人喝茶的假设相矛盾, 我们现在知道瑞典人喝茶. 我们也知道另一个人是日本人, 喝咖啡.

要添加最后一个事实, 需要另一个目标. Left0 检查 x 是否在列表 l 中直接位于 y 的左边:

(define (lefto x y l)
  (let ((vt (var 't)))
    (any (all (caro l x)
              (cdro l vt)
              (caro vt y))
         (all (cdro l vt)
              (lambda (s)
                ((lefto x y vt) s))))))

使用 left0, 谜题可以被解决:

(run* h (all (== h (list (var 'h1)
                         (var 'h2)))
             (memo (list 'Swede (var 'drink)) h)
             (memo (list (var 'person) 'Tea) h)
             (memo (list 'Japanese 'Coffee) h)
             (lefto (list (var 'person) 'Tea)
                    (var 'house) h)))
=> '(((swede tea) (japanese coffee)))

要解决斑马谜题, 需要另一个谓词. 它表示 x 在 y 旁边.

X 在 y 旁边, 如果 x 在 y 的左边或者 y 在 x 的左边, 所以:

(define (nexto x y l)
  (any (lefto x y l)
       (lefto y x l)))

表示一排房子中一栋房子位置的谓词不是必需的, 因为房子可以直接放在初始记录中:

(list (list 'norwegian (var 'c1) (var 'd1) (var 'p1) (var 'o1))
      (var 'h2)
      (list (var 'n2) (var 'c2) 'milk (var 'p2) (var 'o2))
      (var 'h4)
      (var 'h5))

为未知参数发明大量唯一的变量名有点麻烦, 但因为这些变量的初始值并不是很有趣, 所以它们可以用匿名变量替换:

(list (list 'norwegian (_) (_) (_) (_))
      (_)
      (list (_) (_) 'milk (_) (_))
      (_)
      (_))

这里是解决斑马谜题的完整代码:

(define (zebra)
  (let ((h (var 'h)))
    (run* h (all (== h (list (list 'norwegian (_) (_) (_) (_))
                              (_)
                              (list (_) (_) 'milk (_) (_))
                              (_)
                              (_)))
                 (memo (list 'englishman (_) (_) (_) 'red) h)
                 (lefto (list (_) (_) (_) (_) 'green)
                        (list (_) (_) (_) (_) 'ivory) h)
                 (nexto (list 'norwegian (_) (_) (_) (_))
                        (list (_) (_) (_) (_) 'blue) h)
                 (memo (list (_) 'kools (_) (_) 'yellow) h)
                 (memo (list 'spaniard (_) (_) 'dog (_)) h)
                 (memo (list (_) (_) 'coffee (_) 'green) h)
                 (memo (list 'ukrainian (_) 'tea (_) (_)) h)
                 (memo (list (_) 'luckystrikes 'orangejuice (_) (_)) h)
                 (memo (list 'japanese 'parliaments (_) (_) (_)) h)
                 (memo (list (_) 'oldgolds (_) 'snails (_)) h)
                 (nexto (list (_) (_) (_) 'horse (_))
                        (list (_) 'kools (_) (_) (_)) h)
                 (nexto (list (_) (_) (_) 'fox (_))
                        (list (_) 'chesterfields (_) (_) (_)) h)
                 ; (memo (list (_) (_) 'water (_) (_)) h)
                 (memo (list (_) (_) (_) 'zebra (_)) h)))))

该程序应以 1024K 字节的节点池大小运行 (即使用命令 zl -n 1024K 启动 zenlisp 解释器).

(zebra) => '(((norwegian kools _,0 fox yellow)
              (ukrainian chesterfields tea horse blue)
              (englishman oldgolds milk snails red)
              (japanese parliaments coffee zebra green)
              (spaniard luckystrikes orangejuice dog ivory)))

注意, 这个谜题实际上是欠定的. 挪威人的饮料是未知的. 如果你更喜欢一个完全指定的查询, 只需取消上面代码中列出“水”作为饮料的事实的注释.

2.8.3. 11.3 实现

完整的实现是用纯符号 LISP 编写的.

唯一需要的库函数是 length. 它是从 zenlisp 的 nmath 包中导入的.

(define amk :t)
(require '~nmath)

11.3.1 基础
这些是 fail 和 succeed 目标. 它们保证有不相交的结果:
```
(define (fail x) ())
(define (succeed x) (list x))
```
Var 创建一个逻辑变量, var-p 检查一个对象是否是逻辑变量. 逻辑变量由像 (? . x) 这样的形式表示, 其中 x 是变量的名称. 注意, 所有逻辑变量都是唯一的实例. [见 page 55]
```
(define (var x) (cons '? x))
(define (var-p x)
  (and (not (atom x))
       (eq (car x) '?)))
```
因为所有变量都是唯一的, var 可以用来创建匿名变量:
```
(define (_) (var '_))
```
Empty-s 代表无知:
```
(define empty-s ())
```
知识由替换 (substitutions) 表示. 替换使用关联列表实现. Empty-s 是一个空替换.

Ext-s 将变量 x 与值 v 的关联添加到替换 s 中.
```
(define (ext-s x v s) (cons (cons x v) s))
```
Walk 在替换 s 中查找 x 的值:
```
(walk vx '((vx . bread))) => 'bread
```
(Vx 表示逻辑变量 x, 即形式 (? . x).)

Walk 可能看起来像 assoc 或 assq, 但它做得更多:
```
(define (walk x s)
  (cond ((not (var-p x)) x)
        (t (let ((v (assq x s)))
             (cond (v (walk (cdr v) s))
                   (t x))))))
```
当与一个变量关联的值是另一个变量时, walk 会查找那个另一个变量, 从而跟随变量链:
```
(walk vx '((vx . vy) (vz . sushi) (vy . vz ))) => 'sushi
```
这就是变量的合一是如何实现的.

当传递给 walk 的变量是新鲜的, 或者在跟随变量链时发现一个新鲜的变量时, 返回新鲜的变量:
```
(walk vx empty-s) => vx
```
这就是为什么新鲜变量是头等对象. atomic 谓词代替 atom 使用, 因为 zenlisp 将闭包实现为列表.
```
(define (atomic x)
  (or (atom x)
      (eq (car x) 'closure)))
```
Unify 是 amk 的核心. 它将 x 与 y 合一, 在 s 中查找变量的值.
```
(define (unify x y s)
  (let ((x (walk x s))
        (y (walk y s)))
    (cond ((eq x y) s)
          ((var-p x) (ext-s x y s))
          ((var-p y) (ext-s y x s))
          ((or (atomic x) (atomic y)) :f)
          (t (let ((s (unify (car x) (car y) s)))
               (and s (unify (cdr x) (cdr y) s)))))))
```
成功时, unify 返回 s 或添加了新替换的 s 的扩展. 失败时返回 :f.

11.3.2 目标

这是 = 目标. = 像 unify, 但它成功或失败, 而不是返回一个替换或假.

(define (== g1 g2)
  (lambda (s)
    (let ((s2 (unify g1 g2 s)))
      (cond (s2 (succeed s2))
            (t (fail s))))))

注意 == 返回一个必须应用于一个替换才能让合一发生的 lambda 函数:

(== vq 'orange-juice) => {closure #s}
((== vq 'orange-juice) empty-s) => '(((vq . orange-juice)))

还要注意, 当 == 成功时, 它在结果替换周围添加了另一个列表.

这是 any 目标:

(define (any . g*)
  (lambda (s)
    (letrec
      ((try (lambda g*
              (cond ((null g*) (fail s))
                    (t (append ((car g*) s)
                               (apply try (cdr g*))))))))
      (apply try g*))))

它通过将 g* 列表的每个成员应用于给定的知识 s 并附加结果来形成一个替换列表:

((any (== vq 'ice) (== vq 'cream)) empty-s)
=> '(((vq . ice)) ((vq . cream)))

在 any 返回的替换列表中, 每个单独的替换都没有冲突的关联.

Any 是唯一可能产生多个替换的目标.

这里是 all:

(define (all . g*)
  (lambda (s)
    (letrec
      ((try (lambda (g* s*)
              (cond ((null g*) s*)
                    (t (try (cdr g*)
                            (apply append
                                   (map (car g*) s*))))))))
      (try g* (succeed s)))))

All 将其子目标应用于知识 s*.

因为它的某些子目标可能是 any (可能产生多个替换), 所以 all 将每个目标映射到一个替换列表.

映射消除了 s* 的所有替换中与当前目标相矛盾的所有关联. 剩余的结果被附加起来形成一个新的替换列表 s*1.

all 的下一个子目标被映射到 s*1 上, 得到 s*2, 等等.

每个子目标都应用于到目前为止应用的子目标的合取.

One 类似于 any, 但它不是附加替换, 而是返回第一个成功的子目标的结果:

(define failed null)
(define (one . g*)
  (lambda (s)
    (letrec
      ((try (lambda g*
              (cond ((null g*) (fail s))
                    (t (let ((out ((car g*) s)))
                         (cond ((failed out)
                                (apply try (cdr g*)))
                               (t out))))))))
      (apply try g*))))

这里是 neg 目标. 它的实现比它的应用更直接:

(define (neg g)
  (lambda (s)
    (let ((out (g s)))
      (cond ((failed out) (succeed s))
            (t (fail s))))))

Choice 是一个促进集合创建的实用目标:

(run* vq (choice vq '(orange banana kiwi)))

是

(run* vq (any (== vq 'orange)
              (== vq 'banana)
              (== vq 'kiwi)))

的缩写. 这是代码:

(define (choice x lst)
  (cond ((null lst) fail)
        (t (any (== x (car lst))
                (choice x (cdr lst))))))

11.3.2 接口
Occurs 和 circular 是将由 walk* 使用的辅助函数, walk* 紧随其后解释.

Occurs 检查符号或变量 x 是否出现在形式 y 中. 像 walk 一样, occurs 跟随变量链. 变量的值在 s 中查找.
```
(define (occurs x y s)
  (let ((v (walk y s)))
    (cond ((var-p y) (eq x y))
          ((var-p v) (eq x v))
          ((atomic v) :f)
          (t (or (occurs x (car v) s)
                 (occurs x (cdr v) s))))))
```
一个包含对该变量引用的变量的值被称为循环的 (circular):
```
((== vq (list vq)) empty-s) => '(((vq . (vq))))
```
一个循环的答案是无效的, 因为它是自引用的.

circular 函数检查一个变量的值是否是循环的:
```
(define (circular x s)
  (let ((v (walk x s)))
    (cond ((eq x v) :f)
          (t (occurs x (walk x s) s)))))
```
Walk* 像 walk: 它将一个变量 x 变成一个值 v. 此外, 它还替换 v 中找到的所有变量及其值.

Walk* 使 amk 计算的答案易于理解:
```
((all (== vq (list vx)) (== vx 'foo)) empty-s)
=> '(((vx . foo) (vq . (vx))))
(walk* vq '((vx . foo) (vq . (vx))))
=> '(foo)
```
当 walk* 遇到一个新鲜的变量时, 它将它留在结果中.

当要 walk* 的变量绑定到一个循环的值时, walk* 返回 :bottom.
```
(define :bottom (var ':bottom))

(define (walk* x s)
  (letrec
    ((w* (lambda (x s)
           (let ((x (walk x s)))
             (cond ((var-p x) x)
                   ((atomic x) x)
                   (t (cons (w* (car x) s)
                            (w* (cdr x) s))))))))
    (cond ((circular x s) :bottom)
          ((eq x (walk x s)) empty-s)
          (t (w* x s)))))
```
Reify-name 生成一个具体化的名称.
```
(define (reify-name n)
  (implode (append '#_, n)))
```
Reify 创建一个替换, 其中 v 中包含的每个新鲜变量都与一个唯一的具体化名称相关联:
```
(reify (list vx vy vz )) => '((vz . _,2) (vy . _,1) (vx . _,0))
```
传递给 reify 的值 v 必须已经过 walk*ed.
```
(define (reify v)
  (letrec
    ((reify-s
       (lambda (v s)
         (let ((v (walk v s)))
           (cond ((var-p v)
                  (ext-s v (reify-name (length s)) s))
                 ((atomic v) s)
                 (t (reify-s (cdr v)
                             (reify-s (car v)
                                      s))))))))
    (reify-s v empty-s)))
```
Preserve-bottom 实现 bottom 保持. 这里没什么惊喜.

解释: 术语 bottom 在数学中用来表示一个未定义的结果, 比如一个发散的函数. Bottom 保持是一个原则, 它说任何包含 bottom 元素的任何形式本身都等于 bottom.

当一个答案包含变量 :bottom 时, 该答案具有循环结构, 并且导致该答案的查询应该失败.
```
(define (preserve-bottom s)
  (cond ((occurs :bottom s s) ())
        (t s)))
```
Run* 是向 amk 提交查询的主要接口:
```
(define (run* x g)
  (preserve-bottom
    (map (lambda (s)
           (walk* x (append s (reify (walk* x s)))))
         (g empty-s))))
```
X 可以是一个逻辑变量或 ().

当 x 是一个变量时, run* 返回该变量的一个或多个值. 当 x=() 时, 它返回 '(()) 或 ().

当一个查询失败时, run* 返回 ().

Run* 运行目标 g, 然后对答案的每个替换进行 walk*s.

它还具体化每个结果替换中包含的新鲜变量.

这些是在前面部分中假定被定义的一些预定义变量. (define vp (var 'p)) (define vq (var 'q))

以下代码包含一组属于 amk 的实用目标. 它们在本章前面已经详细讨论过. (define (conso a d p) (= (cons a d) p)) (define (caro p a) (conso a (_) p)) (define (cdro p d) (conso (_) d p)) (define (pairo p) (conso (_) (_) p)) (define (eqo x y) (= x y)) (define (nullo a) (eqo a ()))

(define (memo x l) (let ((vt (var 't))) (any (caro l x) (all (cdro l vt) (lambda (s) ((memo x vt) s))))))

(define (appendo x y r) (any (all (= x ()) (= y r)) (let ((vh (var 'h)) (vt (var 't)) (va (var 'a))) (all (conso vh vt x) (conso vh va r) (lambda (s) ((appendo vt y va) s))))))

(define (memqo x l r) (let ((vt (var 't))) (any (all (caro l x) (== l r)) (all (cdro l vt) (lambda (s) ((memqo x vt r) s))))))

(define (rmemqo x l r) (let ((vt (var 't))) (any (all (cdro l vt) (lambda (s) ((rmemqo x vt r) s))) (all (caro l x) (== l r)))))

_SRC_WITH_CAPTION

3. 第三部分 zenlisp 实现

Zenlisp 是本书前面部分介绍和讨论的纯符号 LISP 语言的解释器. 它是用 ANSI C (C89) 和 zenlisp 编写的. 这部分重现了 zenlisp 解释器的完整源代码, 包括大量的注释. 第一章将描述大约 3000 行的 C 代码, 第二章将描述大约 1000 行的 zenlisp 代码, 它们共同构成了整个系统.

3.1. 12. c 部分

C 部分的完整源代码包含在文件 `zl.c` 中.

/*
 * zenlisp -- an interpreter for symbolic LISP
 * By Nils M Holm <nmh@t3x.org>, 2007, 2008
 * Feel free to copy, share, and modify this program.
 * See the file LICENSE for details.
 */

Zenlisp 是一个树遍历解释器, 它实现了浅绑定 (shallow binding)、一个常数空间的标记-清除垃圾回收器 (mark and sweep garbage collector) 和大数算术 (bignum arithmetics) (尽管这些被认为是相当深奥的特性, 并且完全包含在 LISP 部分).

3.1.1. 12.1 前奏和数据声明

#include <stdlib.h>
#ifdef __TURBOC__
 #include <io.h>
 #include <alloc.h>
#else
 #include <unistd.h>
 #ifndef __MINGW32__
 #ifndef __CYGWIN__
 #define setmode(fd, mode)
 #endif
 #endif
#endif
#include <stdio.h>
#include <string.h>
#include <ctype.h>
#include <fcntl.h>

#define VERSION 2
#define RELEASE "2008-09-19"

DEFAULT_NODES 是 zenlisp 使用的节点池的默认大小. 节点池有一个静态大小, 在运行时不能增长. 可以使用命令行选项指定不同的节点大小. 更大的节点池 (在一定限制内) 通常意味着更快的操作和更大的内存占用.

每个节点由一个 “car” 字段、一个 “cdr” 字段和一个 “tag” 字段组成. 前两个字段的大小都是一个 int, tag 字段的大小是一个 char, 所以节点池的总大小计算如下:

SizePool = Nodes * (2 * sizeof(int) + 1)

MINIMUM_NODES 常量指定了可以容纳系统 LISP 部分的最小池的大小.

#define DEFAULT_NODES 131072
#define MINIMUM_NODES 12280

DEFAULT_IMAGE 是系统启动时要加载的 LISP 映像文件的位置. 可以在命令行上指定不同的映像文件.

#ifndef DEFAULT_IMAGE
 #define DEFAULT_IMAGE "/u/share/zenlisp/zenlisp"
#endif

counter 结构体是一种表示大数的便携机制. 它用于在运行时收集有关分配和归约周期的数据. 其 n 成员存储个位, n1k 成员存储千位, 等等.

struct counter {
 int n, n1k, n1m, n1g;
};

Error_context 结构用于存储发生错误时的上下文, 以便稍后可以报告错误. 每个错误消息的格式如下

* file: line: function: message: expression
* additional argument
* Trace: function ...

file, expression, additional argument, and Trace: … 部分是可选的. 错误上下文保存了消息的各个部分:

field	meaning
msg	error message
arg	additional argument
expr	expression that caused the error or NO_EXPR
file	input file or NULL for stdin
line	input line number
fun	function in which the error occurred or NIL
frame	current call frame, used to print trace

struct Error_context {
 char *msg;
 char *arg;
 int expr;
 char *file;
 int line;
 int fun;
 int frame;
};

这是一个符号名的最大长度, 以及一个源路径的最大长度:

#define SYMBOL_LEN 256
#define MAX_PATH_LEN 256

以下标志用于控制垃圾回收器. ATOM_FLAG 也用于区分原子和对. 确实, 在 zenlisp 中, 除了原子 (符号) 和对外, 没有其他类型.

Flag	Meaning
ATOM_FLAG	This node is an atom
MARK_FLAG	Used to tag live nodes during GC
SWAP_FLAG	Used to indicate that this node is not yet completely visited

当设置了 SWAP_FLAG 时, 节点的 “car” 和 “cdr” 字段将被交换, 以便在垃圾回收中访问 cdr 子节点. 因此得名.

#define ATOM_FLAG 0x01
#define MARK_FLAG 0x02
#define SWAP_FLAG 0x04

这里有一些魔术值. NIL 是空列表. 它表示“不在列表中”, 因此它的 (内部) 值是节点池的无效索引. EOT 是 (输入) 文本的结尾. 它用于表示文件或 TTY 输入的结尾. 当读取器找到一个点 (“.”) 或一个右括号 (“)”) 时, 会返回 DOT 和 R_PAREN. NO_EXPR 表示错误不是由任何特定的表达式引起的.

#define NIL -1
#define EOT -2
#define DOT -3
#define R_PAREN -4
#define NO_EXPR -5

这些是 zenlisp 求值器在将程序归约为其范式时可能经历的状态. 它们将在 eval 函数的描述和代码中详细解释.

State	Meaning
MATOM	evaluating an atom; this is the original state
MLIST	evaluating a list of function arguments
MBETA	evaluating the body of a function
MBIND	evaluating the bindings of let
MBINR	evaluating the bindings of letrec
MLETR	evaluating the term of let or letrec
MCOND	evaluating predicates of cond
MCONJ	evaluating expressions of and (but not the last one)
MDISJ	evaluating expressions of or (but not the last one)

enum Evaluator_states {
 MATOM = '0',
 MLIST,
 MBETA,
 MBIND,
 MBINR,
 MLETR,
 MCOND,
 MCONJ,
 MDISJ
};

节点池的大小, 以节点为单位.

int Pool_size;

数组 Car, Cdr 和 Tag 构成了节点池. Car 和 Cdr 保存 cons 单元的 car 和 cdr 字段, Tag 保存原子标志和垃圾回收器标签. 节点 n 的 car 字段由 Car[n] 引用, 同一个节点的 cdr 字段由 Cdr[n] 引用, 它的标签通过 Tag[n] 访问.

注意, 节点池内部不使用指针. 每个 car 和 cdr 字段 (除了原子) 都包含形成节点池的数组中另一个节点的偏移量. 图 9 描述了一个 cons 单元的内部表示. 该单元位于偏移量 5 处, 这意味着 Car 保存其 car 字段, Cdr 保存其 cdr 字段. 它的 car 字段包含整数 17, 所以它的 car 值存储在偏移量 17 的节点中. 同样, cons 单元的 cdr 部分的值存储在偏移量 29 的节点中.

因为使用整数偏移量代替指针进行间接寻址, 所以整个节点池可以基本上使用三个 write() 操作转储到磁盘, 并在稍后使用 read() 恢复. 所有的寻址都是相对于池数组的.

int *Car, /* Car*Cdr*Tag = Node Pool */
 *Cdr;
char *Tag;

这是一个空闲节点的 cdr 链接列表.

int Freelist;

以下变量在垃圾回收期间受到保护. 绑定到其中任何一个的值都不会被回收. Tmp_car 和 Tmp_cdr 用于在分配时保护子节点. 另外两个在需要时使用.

int Tmp_car, Tmp_cdr; /* GC-safe */
int Tmp, Tmp2;

Infile 是当前正在读取的输入文件的名称. NULL 值表示从 REPL (read-eval-print loop) 读取终端输入. Input 是输入流本身.

Rejected 是一个被放回输入流的字符. 当 Rejected=EOT 时, 没有字符被拒绝. 当然, 也可以使用 ungetc(), 但这个解决方案更透明, 并且更容易移植到其他语言. ²⁰

3.1.2. 12.2 杂项函数

这些是用于访问嵌套列表成员的便利宏.

#define caar(x) (Car[Car[x]])
#define cadr(x) (Car[Cdr[x]])
#define cdar(x) (Cdr[Car[x]])
#define cddr(x) (Cdr[Cdr[x]])
#define caaar(x) (Car[Car[Car[x]]])
#define caadr(x) (Car[Car[Cdr[x]]])
#define cadar(x) (Car[Cdr[Car[x]]])
#define caddr(x) (Car[Cdr[Cdr[x]]])
#define cdaar(x) (Cdr[Car[Car[x]]])
#define cddar(x) (Cdr[Cdr[Car[x]]])
#define cdddr(x) (Cdr[Cdr[Cdr[x]]])
#define caddar(x) (Car[Cdr[Cdr[Car[x]]]])
#define cadddr(x) (Car[Cdr[Cdr[Cdr[x]]]])

所有解释器输出 (除了启动错误消息) 都通过这个接口.

void nl(void) {
 putc('\n', Output);
 if (Output == stdout) fflush(Output);
}

void pr(char *s) {
 fputs(s, Output);
}

void pr_num(int n) {
 fprintf(Output, "%d", n);
}

3.1.3. 12.3 错误报告

如果传递了一个非空的调用帧, Print_call_trace 会打印一个调用跟踪.

void print_call_trace(int frame) {
 int s, n;

 s = frame;
 n = Max_trace;
 while (s != NIL) {
 if (n == 0 || Cdr[s] == NIL || cadr(s) == NIL) break;
 if (n == Max_trace) pr("* Trace:");
 n = n-1;
 pr(" ");
 Quotedprint = 1;
 print(cadr(s));
 s = Car[s];
 }
 if (n != Max_trace) nl();
}

为后续报告注册一个错误上下文并设置错误标志. 如果有多个错误, 只注册第一个.

int error(char *m, int n) {
 if (Error_flag) return NIL;
 Error.msg = m;
 Error.expr = n;
 Error.file = Infile;
 Error.line = Line;
 Error.fun = Function_name;
 Error.frame = Frame;
 Error_flag = 1;
 return NIL;
}

打印当前存储在错误上下文中的错误消息并清除错误标志.

void zen_print_error(void) {
 pr("* ");
 if (Error.file) {
 pr(Error.file);
 pr(": ");
 }
 pr_num(Error.line);
 pr(": ");
 if (Error.fun != NIL) {
 Quotedprint = 1;
 print(Error.fun);
 }
 else {
 pr("REPL");
 }
 pr(": ");
 pr(Error.msg);
 if (Error.expr != NO_EXPR) {
 if (Error.msg) pr(": ");
 Quotedprint = 1;
 print(Error.expr);
 }
 nl();
 if (Error.arg) {
 pr("* ");
 pr(Error.arg); nl();
 Error.arg = NULL;
 }
 if (!Fatal_flag && Error.frame != NIL)
 print_call_trace(Error.frame);
 Error_flag = 0;
}

报告一个致命错误并退出.

void fatal(char *m) {
 Error_flag = 0;
 Fatal_flag = 1;
 error(m, NO_EXPR);
 zen_print_error();
 pr("* Fatal error, aborting");
 nl();
 exit(1);
}

3.1.4. 12.4 计数函数

void reset_counter(struct counter *c) {
 c->n = 0;
 c->n1k = 0;
 c->n1m = 0;
 c->n1g = 0;
}

将计数器 c 增加 k. 断言 0<=k<=1000

void count(struct counter *c, int k) {
  char *msg = "statistics counter overflow";

  c->n = c->n+k;
  if (c->n >= 1000) {
    c->n = c->n - 1000;
    c->n1k = c->n1k + 1;
    if (c->n1k >= 1000) {
      c->n1k = 0;
      c->n1m = c->n1m+1;
      if (c->n1m >= 1000) {
        c->n1m = 0;
        c->n1g = c->n1g+1;
        if (c->n1g >= 1000) {
          error(msg, NO_EXPR);
        }
      }
    }
  }
}

将一个计数器结构转换为其存储值的字符串表示. 将插入逗号来标记千位. 调用者必须提供一个足够大的字符串缓冲区. 一个计数器结构中可以存储的最大值是 999,999,999,999.

char *counter_to_string(struct counter *c, char *buf) {
 int i;

 i = 0;
 if (c->n1g) {
 sprintf(&buf[i], "%d,", c->n1g);
 i = strlen(buf);
 }
 if (c->n1m || c->n1g) {
 if (c->n1g)
 sprintf(&buf[i], "%03d,", c->n1m);
 else
 sprintf(&buf[i], "%d,", c->n1m);
 i = strlen(buf);
 }
 if (c->n1k || c->n1m || c->n1g) {
 if (c->n1g || c->n1m)
 sprintf(&buf[i], "%03d,", c->n1k);
 else
 sprintf(&buf[i], "%d,", c->n1k);
 i = strlen(buf);
 }
 if (c->n1g || c->n1m || c->n1k)
 sprintf(&buf[i], "%03d", c->n);
 else
 sprintf(&buf[i], "%d", c->n);
 return buf;
}

3.1.5. 12.5 内存管理

mark() 函数实现了一个有限状态机 (FSM), 它遍历以节点 n 为根的树. 该函数将它在遍历过程中遇到的所有节点标记为“活动”节点, 即不能被回收的节点. FSM 使用三个状态 (1,2,3), 这些状态是使用收集器标志 MARK_FLAG (M) 和 SWAP_FLAG (S) 形成的. MARK_FLAG 是一个状态标志, 同时也是“标记”标志 — 用于标记活动节点. 下图说明了根节点在遍历一个由三个节点组成的树时的状态. 标记的节点以灰色背景呈现.

State 1: 节点 N 未被访问. 父节点指向 NIL, 两个标志都已清除.

State 2: N 现在指向根节点的 car 子节点, 父指针指向根节点, 父节点的父节点存储在根节点的 car 部分. 两个标志都已设置. 节点现在被标记.

State 3: 当 car 子节点完成时, 根的 car 指针被恢复, 祖父节点移动到根节点的 cdr 部分, N 移动到 cdr 子节点. S 标志被清除, 根节点现在被完全遍历.

State 3: 当 FSM 从 cdr 子节点返回时, 它在状态 3 中找到根节点. 为了返回到根, 它恢复根节点的 cdr 指针和父节点. N 上移到根节点. 因为 N 被标记且父节点是 NIL, 遍历完成.

当 FSM 在遍历过程中遇到一个已经标记的节点时, 它会立即返回到父节点. 因为节点在它们的后代被遍历之前就被标记了, 所以 FSM 可以遍历循环结构而不会进入无限循环.

当标记阶段找到一个设置了 ATOM_FLAG 的对象时, 它只遍历其 cdr 字段, 而不管 car 字段 (因为它不持有有效的节点偏移量).

/*
 * Mark nodes which can be accessed through N.
 * Using the Deutsch/Schorr/Waite (aka pointer reversal) algorithm.
 * State 1: M==0 S==0 unvisited, process CAR
 * State 2: M==1 S==1 CAR visited, process CDR
 * State 3: M==1 S==0 completely visited, return to parent
 */
void mark(int n) {
 int p, parent;

 parent = NIL;
 while (1) {
 if (n == NIL || Tag[n] & MARK_FLAG) {
 if (parent == NIL) break;
 if (Tag[parent] & SWAP_FLAG) { /* State 2 */
 /* Swap CAR and CDR pointers and */
 /* proceed with CDR. Go to State 3. */
 p = Cdr[parent];
 Cdr[parent] = Car[parent];
 Car[parent] = n;
 Tag[parent] &= ~SWAP_FLAG; /* S=0 */
 Tag[parent] |= MARK_FLAG; /* M=1 */
 n = p;
 }
 else { /* State 3: */
 /* Return to the parent and restore */
 /* parent of parent */
 p = parent;
 parent = Cdr[p];
 Cdr[p] = n;
 n = p;
 }
 }
 else { /* State 1: */
 if (Tag[n] & ATOM_FLAG) {
 /* If this node is an atom, go directly */
 /* to State 3. */
 p = Cdr[n];
 Cdr[n] = parent;
 /*Tag[n] &= ~SWAP_FLAG;*/ /* S=0 */
 parent = n;
 n = p;
 Tag[parent] |= MARK_FLAG; /* M=1 */
 }
 else {
 /* Go to state 2: */
 p = Car[n];
 Car[n] = parent;
 Tag[n] |= MARK_FLAG; /* M=1 */
 parent = n;
 n = p;
 Tag[parent] |= SWAP_FLAG; /* S=1 */
 }
 }
 }
}

标记和清除垃圾回收器: 首先标记所有 Root[] 节点和错误上下文的节点 (如果需要), 然后删除并重建空闲列表. 在构建新空闲列表的循环中清除标记标志.

int gc(void) {
 int i, k;

 k = 0;
 for (i=0; Root[i]; i++) mark(Root[i]);
 if (Error_flag) {
 mark(Error.expr);
 mark(Error.fun);
 mark(Error.frame);
 }
 Freelist = NIL;
 for (i=0; i<Pool_size; i++) {
 if (!(Tag[i] & MARK_FLAG)) {
 Cdr[i] = Freelist;
 Freelist = i;
 k = k+1;
 }
 else {
 Tag[i] &= ~MARK_FLAG;
 }
 }
 if (Max_atoms_used < Pool_size-k) Max_atoms_used = Pool_size-k;
 if (Verbose_GC) {
 pr_num(k);
 pr(" nodes reclaimed");
 nl();
 }
 if (Stat_flag) count(&Collections, 1);
 return k;
}

alloc3() 函数是 zenlisp 的主要节点分配器. 它从空闲列表中移除第一个节点, 并用给定的 car, cdr 和 tag 值对其进行初始化. 当空闲列表为空时, 会触发垃圾回收 (GC). 注意, alloc3() 保护传递给它的值免受 GC 的影响, 所以调用者无需特别小心. 例如, 形式 (x y z) 可以使用代码片段创建:

n = alloc(z, NIL);
n = alloc(y, n);
n = alloc(x, n);

int alloc3(int pcar, int pcdr, int ptag) {
 int n;

 if (Stat_flag) count(&Allocations, 1);
 if (Freelist == NIL) {
 Tmp_cdr = pcdr;
 if (!ptag) Tmp_car = pcar;
 gc();
 Tmp_car = Tmp_cdr = NIL;
 if (Freelist == NIL) fatal("alloc3(): out of nodes");
 }
 n = Freelist;
 Freelist = Cdr[Freelist];
 Car[n] = pcar;
 Cdr[n] = pcdr;
 Tag[n] = ptag;
 return n;
}

Alloc() 是分配 cons 单元的快捷方式.

#define alloc(pcar, pcdr) \
 alloc3(pcar, pcdr, 0)

Save() 将一个节点保存在栈上, unsave() 移除给定数量的值并返回移除的最深的一个.

#define save(n) \
 (Stack = alloc(n, Stack))

int unsave(int k) {
 int n;

 USE(n);
 while (k) {
 if (Stack == NIL) fatal("unsave(): stack underflow");
 n = Car[Stack];
 Stack = Cdr[Stack];
 k = k-1;
 }
 return n;
}

Msave() 和 munsave() 的工作方式与上面的 save() 和 unsave() 类似, 但使用模式栈而不是通用栈. 因为 Mode_stack 存储的是整数值而不是节点, 所以这些值被打包在原子节点的 car 字段中.

#define msave(v) \
 (Car[Mode_stack] = alloc3(v, Car[Mode_stack], ATOM_FLAG))

int munsave(void) {
 int v;

 if (Car[Mode_stack] == NIL) fatal("munsave(): m-stack underflow");
 v = caar(Mode_stack);
 Car[Mode_stack] = cdar(Mode_stack);
 return v;
}

以下函数分别为参数栈和绑定栈重复保存/取消保存过程.

#define asave(n) \
 (Arg_stack = alloc(n, Arg_stack))

int aunsave(int k) {
 int n;

 USE(n);
 while (k) {
 if (Arg_stack == NIL) fatal("aunsave(): a-stack underflow");
 n = Car[Arg_stack];
 Arg_stack = Cdr[Arg_stack];
 k = k-1;
 }
 return n;
}

#define bsave(n) \
 (Bind_stack = alloc(n, Bind_stack))

int bunsave(int k) {
 int n;

 USE(n);
 while (k) {
 if (Bind_stack == NIL) fatal("bunsave(): b-stack underflow");
 n = Car[Bind_stack];
 Bind_stack = Cdr[Bind_stack];
 k = k-1;
 }
 return n;
}

3.1.6. 12.6 符号表

在全局符号表中查找名为 s 的符号. 如果不存在这样的符号, 则返回符号或 NIL.

int find_symbol(char *s) {
 int p, n, i;

 p = Symbols;
 while (p != NIL) {
 n = caar(p);
 i = 0;
 while (n != NIL && s[i]) {
 if (s[i] != (Car[n] & 255)) break;
 n = Cdr[n];
 i = i+1;
 }
 if (n == NIL && !s[i]) return Car[p];
 p = Cdr[p];
 }
 return NIL;
}

检查一个节点是否是 atom 意义上的原子. 注意: atom 也将原始函数、特殊形式处理程序和 {void} 值归类为原子. 这不被 atomic() 函数覆盖.

#define atomic(n) \
 ((n) == NIL || (Car[n] != NIL && (Tag[Car[n]] & ATOM_FLAG)))

symbolic() 函数检查给定的节点是否表示一个符号. 这可能是澄清原子、符号和原子节点之间区别的正确地方.

图 14 显示了一个包含符号 foo 的列表, 以所谓的盒子表示法表示. 每个包含三个较小盒子的盒子代表一个节点, 每个较小的盒子代表该节点的一个字段. 第一个较小的盒子包含 car 字段, 第二个是 tag 字段, 最后一个是 cdr 字段. tag 字段中的三个减号表示没有设置标签.

在图 14 中, 大灰色框外的节点是形式 (foo) 的“骨架”. 它的 cdr 部分指向 (), 它的 car 部分指向符号 foo. 注意, 该符号由 (至少) 四个节点组成: 一个将符号名绑定到值的节点, 以及三个持有符号名字符的节点.

一个设置了 ATOM_FLAG 的节点被称为“原子节点”. 它用于在其 car 字段中保存一些值, 比如一个符号名的字符. 一个“符号”是一个节点, 其 car 部分指向一个原子节点链, 其 cdr 部分指向一个表示该符号值的节点树. 最后, 一个“原子”要么是一个符号, 要么是一个原始函数, 要么是 ().

symbolic() 函数检查一个节点是否表示一个符号.

#define symbolic(n) \
 ((n) != NIL && Car[n] != NIL && (Tag[Car[n]] & ATOM_FLAG))

用给定的名称创建一个符号并返回它.

int string_to_symbol(char *s) {
 int i, n, m, a;

 i = 0;
 if (s[i] == 0) return NIL;
 a = n = NIL;
 while (s[i]) {
 m = alloc3(s[i], NIL, ATOM_FLAG);
 if (n == NIL) {
 n = m;
 save(n);
 }
 else {
 Cdr[a] = m;
 }
 a = m;
 i = i+1;
 }
 unsave(1);
 return n;
}

创建一个包含给定符号名称的字符串. 如果符号的长度超过 SYMBOL_LEN 个字符, 则报告一个错误.

char *symbol_to_string(int n, char *b, int k) {
 int i;

 n = Car[n];
 for (i=0; i<k-1; i++) {
 if (n == NIL) break;
 b[i] = Car[n];
 n = Cdr[n];
 }
 if (n != NIL) {
 error("symbol_to_string(): string too long", NO_EXPR);
 return NULL;
 }
 b[i] = 0;
 return b;
}

向全局符号表添加一个符号. 如果具有给定名称的符号已经存在, 则返回它而不创建一个新的.

int add_symbol(char *s, int v) {
 int n, m;

 n = find_symbol(s);
 if (n != NIL) return n;
 n = string_to_symbol(s);
 m = alloc(n, v? v: n);
 Symbols = alloc(m, Symbols);
 return m;
}

向当前符号表添加一个原始函数 (add_primitive()) 或特殊形式处理程序 (add_special()). 图 15 概述了一个原始函数的内部结构.

特殊符号 {primitive} 将结构标记为原始函数. 原子包含原始函数的 opcode 和一个指向该原始函数所绑定名称的反向链接. 这使得打印机在求值 car 时可以输出 {internal car} 而不仅仅是 {internal}.

特殊形式 (SF) 处理程序与原始函数处理程序具有相同的结构, 但它们使用 {special} 或 {special_cbv} 符号代替 {primitive}. 使用 {special_cbv} 符号的 SF 处理程序是按值调用的. 其他 SF 处理程序是按名称调用的.

int add_primitive(char *name, int opcode) {
 int y;

 y = add_symbol(name, 0);
 Cdr[y] = alloc(S_primitive, NIL);
 cddr(y) = alloc3(opcode, NIL, ATOM_FLAG);
 cdddr(y) = y;
 return y;
}

int add_special(char *name, int opcode, int cbv) {
 int y;

 y = add_symbol(name, 0);
 Cdr[y] = alloc(cbv? S_special_cbv: S_special, NIL);
 cddr(y) = alloc3(opcode, NIL, ATOM_FLAG);
 cdddr(y) = y;
 return y;
}

3.1.7. 12.7 读取器

所有解释器输入都通过这个接口.

int _rdch(void) {
 int c;

 if (Rejected != EOT) {
 c = Rejected;
 Rejected = EOT;
 return c;
 }
 c = getc(Input);
 if (feof(Input)) return EOT;
 if (c == '\n') Line = Line+1;
 return c;
}

#define rdch() \
 tolower(_rdch())

read_list() 函数读取正确的列表和不正确的列表 (当然包括点对). 它调用 zread() 来读取列表的每个成员. Zread() 反过来可能会调用 read_list() 来读取子列表. 当 read_list() 被调用时, 初始的左括号已经被移除了.

Read_read() 检查格式不正确的列表 (原文如此!) 并报告各种错误, 如丢失的右括号和在意外位置出现的点. 如果成功, 它返回读取的列表, 否则返回 ().

int read_list(void) {
 int n,
 lst,
 app,
 count;
 char *badpair;

 badpair = "bad pair";
 Paren_level = Paren_level+1;
 lst = alloc(NIL, NIL); /* Root node */
 save(lst);
 app = NIL;
 count = 0;
 while (1) {
 if (Error_flag) {
 unsave(1);
 return NIL;
 }
 n = zread();
 if (n == EOT) {
 if (Load_level) return EOT;
 error("missing ')'", NO_EXPR);
 }
 if (n == DOT) {
 if (count < 1) {
 error(badpair, NO_EXPR);
 continue;
 }
 n = zread();
 Cdr[app] = n;
 if (n == R_PAREN || zread() != R_PAREN) {
 error(badpair, NO_EXPR);
 continue;
 }
 unsave(1);
 Paren_level = Paren_level-1;
 return lst;
 }
 if (n == R_PAREN) break;
 if (app == NIL)
 app = lst;
 else
 app = Cdr[app];
 Car[app] = n;
 Cdr[app] = alloc(NIL, NIL);
 count = count+1;
 }
 Paren_level = Paren_level-1;
 if (app != NIL) Cdr[app] = NIL;
 unsave(1);
 return count? lst: NIL;
}

这个函数检查给定的字符是否是分隔符. 分隔符分隔输入流中的单个标记.

#define is_delimiter(c) \
 ((c) == ' ' || \
 (c) == '\t' || \
 (c) == '\n' || \
 (c) == '\r' || \
 (c) == '(' || \
 (c) == ')' || \
 (c) == ';' || \
 (c) == '.' || \
 (c) == '#' || \
 (c) == '{' || \
 (c) == '\'')

读取一个压缩列表 (不包括引入的“#”字符) 并返回它.

int read_condensed(void) {
 int n, c, a;
 char s;

 n = alloc(NIL, NIL);
 save(n);
 a = NIL;
 s = 0;
 c = rdch();
 while (!is_delimiter(c)) {
 if (a == NIL) {
 a = n;
 }
 else {
 Cdr[a] = alloc(NIL, NIL);
 a = Cdr[a];
 }
 s = c;
 Car[a] = add_symbol(s, S_void);
 c = rdch();
 }
 unsave(1);
 Rejected = c;
 return n;
}

将一个字符串转换为单字符符号的列表 (一个压缩列表). 返回结果列表. 这个函数在内部用于将数值转换为 zenlisp 打印机可以打印的形式, 例如 "12345" -—> #12345.

int explode_string(char *sym) {
 int n, a, i;
 char s;

 n = alloc(NIL, NIL);
 save(n);
 a = NIL;
 s = 0;
 i = 0;
 while (sym[i]) {
 if (a == NIL) {
 a = n;
 }
 else {
 Cdr[a] = alloc(NIL, NIL);
 a = Cdr[a];
 }
 s = sym[i];
 Car[a] = add_symbol(s, S_void);
 i += 1;
 }
 unsave(1);
 return n;
}

引用节点 n.

int quote(int n) {
 int q;

 q = alloc(n, NIL);
 return alloc(S_quote, q);
}

读取一个符号并返回它. 如果该符号尚未在符号表中, 则添加它.

int read_symbol(int c) {
 char s[SYMBOL_LEN];
 int i;

 i = 0;
 while (!is_delimiter(c)) {
 if (i >= SYMBOL_LEN-2) {
 error("symbol too long", NO_EXPR);
 i = i-1;
 }
 s[i] = c;
 i = i+1;
 c = rdch();
 }
 s[i] = 0;
 Rejected = c;
 return add_symbol(s, S_void);
}

检查两个形式是否相等. 这个函数等同于 zenlisp 的 equal 函数. 因为 equal 是用 zenlisp 编写的, 所以此时它还不可用.

int equals(int n, int m) {
 if (n == m) return 1;
 if (n == NIL || m == NIL) return 0;
 if (Tag[n] & ATOM_FLAG || Tag[m] & ATOM_FLAG) return 0;
 return equals(Car[n], Car[m])
 && equals(Cdr[n], Cdr[m]);
}

verify() 函数读取一个跟在 => 运算符后面的形式, 并将其与最近归约的表达式的范式进行比较. 如果形式不同, 它会报告一个错误.

void verify(void) {
 int expected;

 expected = zread();
 if (!atomic(expected) && Car[expected] == S_quote)
 expected = cadr(expected);
 if (!equals(expected, Cdr[S_last]))
 error("Verification failed; expected", expected);
}

读取一个不可读的对象 (原文如此!) 并报告它.

int unreadable(void) {
 #define L 256
 int c, i;
 static char b[L];

 i = 0;
 b = '{';
 c = '{';
 while (c != '}' && c != EOT && i < L-2) {
 b[i++] = c;
 c = rdch();
 }
 b[i] = '}';
 b[i+1] = 0;
 Error.arg = b;
 return error("unreadable object", NO_EXPR);
}

Zread() 是 zenlisp 的读取器接口. 它从输入流中读取一个形式, 并返回一个节点树, 该树是该形式的内部表示. 它还跳过注释并求值 => 运算符. 当到达输入流的末尾时, 调用 zread() 会产生 EOT.

int zread(void) {
 int c;

 c = rdch();
 while (1) {
 while (c == ' ' || c == '\t' || c == '\n' || c == '\r') {
 if (Error_flag) return NIL;
 c = rdch();
 }
 if (c == '=' && Paren_level == 0) {
 c = rdch();
 if (c != '>') {
 Rejected = c;
 c = '=';
 break;
 }
 if (Verify_arrows) verify();
 }
 else if (c != ';') {
 break;
 }
 while (c != '\n') c = rdch();
 }
 if (c == EOT) return EOT;
 if (c == '(') {
 return read_list();
 }
 else if (c == '\'') {
 return quote(zread());
 }
 else if (c == '#') {
 return read_condensed();
 }
 else if (c == ')') {
 if (!Paren_level) return error("unexpected ')'", NO_EXPR);
 return R_PAREN;
 }
 else if (c == '.') {
 if (!Paren_level) return error("unexpected '.'", NO_EXPR);
 return DOT;
 }
 else if (c == '{') {
 return unreadable();
 }
 else {
 return read_symbol(c);
 }
}

3.1.8. 12.8 原始操作处理程序

zenlisp 的原始函数 (primitive function) 是一个用 C 实现的 LISP 函数. 它的实现被称为“原始操作处理程序”.

本节讨论 zenlisp 的原始函数. 每个原始操作处理程序接收一个表达式并返回其值. 此时, 原语的参数已经是它们的范式.

这些函数是报告常见错误的快捷方式.

int wrong_arg_count(int n) {
 return error("wrong argument count", n);
}

int bad_argument_list(int n) {
 return error("bad argument list", n);
}

像下面的 cons 原型这样的 Zenlisp 原型具有以下通用形式:

(function argument1 ...) ----> result1 | result2

Function 是被描述的函数, 每个 argument 指定一个参数的类型, result 是结果范式的类型, … 表示前面数据项的零个或多个实例. 箭头表示从参数类型到范式类型的映射. 竖线 (“|”) 表示逻辑“或”. 它也可能出现在参数列表中.

注意, 原型不是 zenlisp 语言的一部分. 它们仅用于以正式的方式描述函数.

(cons form form) ----> pair

int z_cons(int n) {
 int m, m2;
 m = Cdr[n];
 if (m == NIL || Cdr[m] == NIL || cddr(m) != NIL)
 return wrong_arg_count(n);
 m2 = cadr(m);
 m = alloc(Car[m], m2);
 return m;
}

(car pair) ----> form

int z_car(int n) {
 int m;
 m = Cdr[n];
 if (m == NIL || Cdr[m] != NIL) return wrong_arg_count(n);
 m = Car[m];
 if ( atomic(m) ||
 Car[m] == S_primitive ||
 Car[m] == S_special ||
 Car[m] == S_special_cbv
 )
 return error("car: cannot split atoms", m);
 return Car[m];
}

(cdr pair) ----> form

int z_cdr(int n) {
 int m;
 m = Cdr[n];
 if (m == NIL || Cdr[m] != NIL) return wrong_arg_count(n);
 m = Car[m];
 if ( atomic(m) ||
 Car[m] == S_primitive ||
 Car[m] == S_special ||
 Car[m] == S_special_cbv
 )
 return error("cdr: cannot split atoms", m);
 return Cdr[m];
}

(eq form1 form2) ----> :t | :f

int z_eq(int n) {
 int m;
 m = Cdr[n];
 if (m == NIL || Cdr[m] == NIL || cddr(m) != NIL)
 return wrong_arg_count(n);
 return Car[m] == cadr(m)? S_true: S_false;
}

(atom form) ----> :t | :f

注意 atom 也为原始函数、特殊形式处理程序和 {void} 返回 :t.

int z_atom(int n) {
 int m;
 m = Cdr[n];
 if (m == NIL || Cdr[m] != NIL) return wrong_arg_count(n);
 if atomic(Car[m]) return S_true;
 m = caar(m);
 return (m == S_primitive || m == S_special ||
 m == S_special_cbv || m == S_void)? S_true: S_false;
}

(explode symbol) ----> list

int z_explode(int n) {
 int m, y, a;
 char s;
 m = Cdr[n];
 if (m == NIL || Cdr[m] != NIL) return wrong_arg_count(n);
 m = Car[m];
 if (m == NIL) return NIL;
 if (!symbolic(m)) return error("explode: got non-symbol", m);
 y = alloc(NIL, NIL);
 save(y);
 a = y;
 m = Car[m];
 s = 0;
 while (m != NIL) {
 s = Car[m];
 Car[a] = add_symbol(s, S_void);
 m = Cdr[m];
 if (m != NIL) {
 Cdr[a] = alloc(NIL, NIL);
 a = Cdr[a];
 }
 }
 unsave(1);
 return y;
}

(implode list) ----> symbol

int z_implode(int n) {
 int m, i;
 char s[SYMBOL_LEN];
 m = Cdr[n];
 if (m == NIL || Cdr[m] != NIL) return wrong_arg_count(n);
 m = Car[m];
 if (m == NIL) return NIL;
 i = 0;
 while (m != NIL) {
 if (!symbolic(Car[m]))
 return error("implode: non-symbol in argument",
 Car[m]);
 if (cdaar(m) != NIL)
 return error(
 "implode: input symbol has multiple characters",
 Car[m]);
 if (i >= SYMBOL_LEN-1)
 return error("implode: output symbol too long", m);
 s[i] = caaar(m);
 i += 1;
 m = Cdr[m];
 }
 s[i] = 0;
 return add_symbol(s, S_void);
}

以下函数处理递归词法环境. 它们由 recursive-bind 函数和 letrec 特殊形式使用.

fix_cached_closures() 函数修复由 letrec 创建的递归绑定. 当使用 letrec 创建递归函数时, lambda 会在将函数绑定到其名称之前封闭函数名称. 这里使用 let 代替 letrec 来演示这一点:

(closure-form env)
(let ((f (lambda (x) (f x)))) f) => (closure #x #fx ((f . {void})))

每当 lambda 创建一个闭包时, 该闭包的词法环境都会被保存在环境栈 (Env_stack) 上. 当 letrec 完成其绑定创建时, 它会调用 fix_cached_closures() 来修复上述形式的递归绑定. 为了界定其作用域, letrec 在开始处理绑定之前会将 :t 推入 Env_stack.

当调用 fix_cached_closures() 时, Env_stack 包含一个像上面 ((f . {void})) 这样的词法环境列表. 绑定栈 (Bind_stack) 的 car 包含一个由 letrec 绑定的符号列表.

fix_cached_closures() 现在所做的是遍历 Env_stack 最顶层作用域中的每个词法环境, 并检查其任何变量是否包含在 Bind_stack 的列表中. 当它找到这样的绑定时, 它会用 Bind_stack 上符号的值来改变环境中与该变量关联的值. 从而, 它将上面的例子改变如下:

(closure #x #fx ((f . {void}))) ----> (closure #x #fx ((f . fouter)))

这里的 fouter 指的是 f 的外部绑定 (来自 Bind_stack). 因为外部 f 绑定到包含固定环境的结构, 所以创建了一个递归结构.

void fix_cached_closures(void) {
 int a, ee, e;

 if (Error_flag || Env_stack == NIL || Env_stack == S_true) return;
 a = Car[Bind_stack];
 while (a != NIL) {
 ee = Env_stack;
 while (ee != NIL && ee != S_true) {
 e = Car[ee];
 while (e != NIL) {
 if (Car[a] == caar(e)) {
 cdar(e) = cdar(a);
 break;
 }
 e = Cdr[e];
 }
 ee = Cdr[ee];
 }
 a = Cdr[a];
 }
}

检查 n 是否是一个关联列表 (“alist”).

int is_alist(int n) {
 if (symbolic(n)) return 0;
 while (n != NIL) {
 if (symbolic(Car[n]) || !symbolic(caar(n)))
 return 0;
 n = Cdr[n];
 }
 return 1;
}

以下函数类似于 fix_cached_closures(), 但它不是修复缓存的环境 (在 Env_stack 上), 而是遍历给定环境 n 的所有绑定, 并修复在 bindings 中明确指定的符号的绑定.

void fix_closures_of(int n, int bindings) {
 int ee, e;
 int bb, b;

 if (atomic(n)) return;
 if (Car[n] == S_closure) {
 fix_closures_of(caddr(n), bindings);
 ee = cdddr(n);
 if (ee == NIL) return;
 ee = Car[ee];
 while (ee != NIL) {
 e = Car[ee];
 bb = bindings;
 while (bb != NIL) {
 b = Car[bb];
 if (Car[b] == Car[e])
 Cdr[e] = Cdr[b];
 bb = Cdr[bb];
 }
 ee = Cdr[ee];
 }
 return;
 }
 fix_closures_of(Car[n], bindings);
 fix_closures_of(Cdr[n], bindings);
}

修复给定环境的所有闭包.

void fix_all_closures(int b) {
 int p;

 p = b;
 while (p != NIL) {
 fix_closures_of(cdar(p), b);
 p = Cdr[p];
 }
}

(recursive-bind alist) ----> alist

副作用: 创建循环绑定.

int z_recursive_bind(int n) {
 int m, env;

 m = Cdr[n];
 if (m == NIL || Cdr[m] != NIL) return wrong_arg_count(n);
 env = Car[m];
 if (!is_alist(env))
 return error("recursive-bind: bad environment", env);
 fix_all_closures(env);
 return env;
}

(bottom ...) ----> undefined

副作用: 停止归约并报告错误.

int z_bottom(int n) {
 n = alloc(S_bottom, Cdr[n]);
 return error("", n);
}

(defined symbol) ----> :t | :f

int z_defined(int n) {
 int m;

 m = Cdr[n];
 if (m == NIL || Cdr[m] != NIL) return wrong_arg_count(n);
 if (!symbolic(Car[m]))
 return error("defined: got non-symbol", Car[m]);
 return cdar(m) == S_void? S_false: S_true;
}

(gc) ----> '(free-nodes peak-usage)

int z_gc(int n) {
 int m;
 char s;

 m = Cdr[n];
 if (m != NIL) return wrong_arg_count(n);
 n = alloc(NIL, NIL);
 save(n);
 sprintf(s, "%d", gc());
 Car[n] = explode_string(s);
 Cdr[n] = alloc(NIL, NIL);
 sprintf(s, "%d", Max_atoms_used);
 Max_atoms_used = 0;
 cadr(n) = explode_string(s);
 unsave(1);
 return n;
}

(quit) ----> undefined

副作用: 从解释器退出.

int z_quit(int n) {
 int m;

 m = Cdr[n];
 if (m != NIL) return wrong_arg_count(n);
 zen_fini();
 exit(0);
}

(symbols) ----> '(symbol ...)

int z_symbols(int n) {
 int m;

 m = Cdr[n];
 if (m != NIL) return wrong_arg_count(n);
 return Symbols;
}

(verify-arrows :t | :f) ----> :t | :f

副作用: 打开或关闭箭头验证.

int z_verify_arrows(int n) {
 int m;

 m = Cdr[n];
 if (m == NIL || Cdr[m] != NIL) return wrong_arg_count(n);
 m = Car[m];
 if (m != S_true && m != S_false)
 return error("verify-arrows: got non truth-value", m);
 Verify_arrows = m == S_true;
 return m;
}

如果 Car[np] 是一个原始函数, 运行相应的原始操作处理程序, 将 np 设置为操作的结果, 并返回 1. 如果 Car[np] 不是一个原始函数, 返回 0.

int primitive(int *np) {
 int n, y;
 int (*op)(int);

 n = np;
 y = Car[n];
 if (Error_flag) return 0;
 if (Car[y] == S_primitive) {
 op = Primitives[cadr(y)];
 }
 else {
 return 0;
 }
 n = (*op)(n);
 np = n;
 return 1;
}

3.1.9. 12.9 特殊形式处理程序

特殊形式处理程序 (special form handler) 是处理“特殊形式”解释的函数. 特殊形式是构成 zenlisp 语法的那些形式. 它们是像 lambda, define 和 cond 这样的关键字的应用.

每个特殊形式处理程序接收四个参数: 特殊形式 n 和三个指向 int 变量的指针, 分别名为 pcf, pmode 和 pcbn. 这些变量构成了求值器的状态.

处理程序以特定于特殊形式的方式重写形式 n 并返回它. 指针 pcf, pmode 和 pcbn 用于控制求值器的核心如何处理重写后的形式. Pmode 是求值器的新模式, pcbn 控制返回的形式是否按名调用, 而 pcf 是所谓的继续标志 (continue flag). 设置 pcf 向求值器发信号, 表明返回的形式是一个表达式而不是一个值. 在这种情况下, 必须继续求值该形式. 因此得名.

特殊形式处理程序还负责检查传递给它们的形式的语法. setup_and_or() 函数准备一个 and 或 or 形式以供归约.

此时事情变得有点混乱, 因为 Bind_stack 也用于存储控制结构的临时结果. 在以下情况下, 它保存 and 或 or 的参数列表.

int setup_and_or(int n) {
 int m;

 m = Cdr[n];
 if (m == NIL) return wrong_arg_count(n);
 bsave(m);
 return Car[m];
}

(and expression ...) ----> form

int z_and(int n, int *pcf, int *pmode, int *pcbn) {
 USE(pcbn);
 if (Cdr[n] == NIL) {
 return S_true;
 }
 else if (cddr(n) == NIL) {
 *pcf = 1;
 return cadr(n);
 }
 else {
 *pcf = 2;
 *pmode = MCONJ;
 return setup_and_or(n);
 }
}

flat_copy() 函数创建一个新列表, 该列表由与传递给它的列表相同的对象组成. 只有构成列表骨架 (spine) 的节点是新分配的. 原始列表和新列表共享相同的成员. 图 16 说明了这个原理.

注意, 为了简洁起见, 在上图中, NIL 包含在每个列表的最后一个框的 cdr 部分, 而不是附加一个指向 () 的指针.

int flat_copy(int n, int *lastp) {
 int a, m, last;

 if (n == NIL) {
 lastp = NIL;
 return NIL;
 }
 m = alloc(NIL, NIL);
 save(m);
 a = m;
 last = m;
 while (n != NIL) {
 Car[a] = Car[n];
 last = a;
 n = Cdr[n];
 if (n != NIL) {
 Cdr[a] = alloc(NIL, NIL);
 a = Cdr[a];
 }
 }
 unsave(1);
 lastp = last;
 return m;
}

(apply function [expression ...] list) ----> form

这个处理程序仅仅重写

(apply function [expression ...] list)

为

(function [expression ...] . list)

并返回它. 注意 list 参数前的点！当 apply 处理程序完成时, 求值器重新归约返回的表达式.

int z_apply(int n, int *pcf, int *pmode, int *pcbn) {
 int m, p, q, last;
 char *err1 = "apply: got non-function",
 *err2 = "apply: improper argument list";

 *pcf = 1;
 USE(pmode);
 *pcbn = 1;
 m = Cdr[n];
 if (m == NIL || Cdr[m] == NIL) return wrong_arg_count(n);
 if (atomic(Car[m])) return error(err1, Car[m]);
 p = caar(m);
 if ( p != S_primitive &&
 p != S_special &&
 p != S_special_cbv &&
 p != S_closure
 )
 return error(err1, Car[m]);
 p = Cdr[m];
 USE(last);
 while (p != NIL) {
 if (symbolic(p)) return error(err2, cadr(m));
 last = p;
 p = Cdr[p];
 }
 p = Car[last];
 while (p != NIL) {
 if (symbolic(p)) return error(err2, Car[last]);
 p = Cdr[p];
 }
 if (cddr(m) == NIL) {
 p = cadr(m);
 }
 else {
 p = flat_copy(Cdr[m], &q);
 q = p;
 while (cddr(q) != NIL) q = Cdr[q];
 Cdr[q] = Car[last];
 }
 return alloc(Car[m], p);
}

提取 cond 表达式当前子句的谓词. Car[Bind_stack] 持有这些子句.

int cond_get_pred(void) {
 int e;

 e = caar(Bind_stack);
 if (atomic(e) || atomic(Cdr[e]) || cddr(e) != NIL)
 return error("cond: bad clause", e);
 return Car[e];
}

准备一个 cond 表达式以供求值. 在 Bind_stack 上保存子句并返回第一个谓词.

int cond_setup(int n) {
 int m;
 m = Cdr[n];
 if (m == NIL) return wrong_arg_count(n);
 bsave(m);
 return cond_get_pred();
}

求值 cond 的下一个子句. N 是当前谓词的值. 如果 n=:f, 返回下一个子句的谓词. 如果 n /==:f, 返回与该谓词关联的表达式 (子句的主体). 当返回一个子句的主体时, 将 Bind_stack 上的上下文设置为 () 以表示 cond 表达式的求值已完成.

int cond_eval_clause(int n) {
 int e;

 e = Car[Bind_stack];
 if (n == S_false) {
 Car[Bind_stack] = Cdr[e];
 if (Car[Bind_stack] == NIL)
 return error("cond: no default", NO_EXPR);
 return cond_get_pred();
 }
 else {
 e = cadar(e);
 Car[Bind_stack] = NIL;
 return e;
 }
}

(cond (predicate1 expression1)
      (predicate2 expression2)
      ...) ----> form

int z_cond(int n, int *pcf, int *pmode, int *pcbn) {
 *pcf = 2;
 *pmode = MCOND;
 USE(pcbn);
 return cond_setup(n);
}

检查 m 是否是一个符号列表.

int is_list_of_symbols(int m) {
 while (m != NIL) {
 if (!symbolic(Car[m])) return 0;
 if (symbolic(Cdr[m])) break;
 m = Cdr[m];
 }
 return 1;
}

(define (symbol1 symbol2 ...) expression) ----> symbol

这个函数将上述形式的函数定义重写为

(lambda (symbol2 ...) expression)

求值该表达式并将其范式绑定到 symbol1. 副作用: 创建全局绑定.

int define_function(int n) {
 int m, y;

 m = Cdr[n];
 if (Car[m] == NIL)
 return error("define: missing function name",
 Car[m]);
 if (!is_list_of_symbols(Car[m])) return bad_argument_list(Car[m]);
 y = caar(m);
 save(cadr(m));
 Tmp2 = alloc(S_lambda, NIL);
 Cdr[Tmp2] = alloc(cdar(m), NIL);
 cddr(Tmp2) = alloc(cadr(m), NIL);
 cdddr(Tmp2) = alloc(NIL, NIL);
 Cdr[y] = eval(Tmp2);
 Tmp2 = NIL;
 unsave(1);
 return y;
}

(define (symbol1 symbol2 ...) expression) ----> symbol
(define symbol expression) ----> symbol

求值一个表达式并将其范式绑定到一个符号. 如果表达式是一个 lambda 特殊形式, 创建一个带有空词法环境的闭包, 从而有效地实现动态作用域. 副作用: 创建全局绑定.

int z_define(int n, int *pcf, int *pmode, int *pcbn) {
 int m, v, y;

 USE(pcf);
 USE(pmode);
 USE(pcbn);
 if (Eval_level > 1) {
 error("define: limited to top level", NO_EXPR);
 return NIL;
 }
 m = Cdr[n];
 if (m == NIL || Cdr[m] == NIL || cddr(m) != NIL)
 return wrong_arg_count(n);
 y = Car[m];
 if (!symbolic(y)) return define_function(n);
 v = cadr(m);
 save(v);
 /* If we are binding to a lambda expression, */
 /* add a null environment */
 if (!atomic(v) && Car[v] == S_lambda) {
 if ( Cdr[v] != NIL && cddr(v) != NIL &&
 cdddr(v) == NIL
 ) {
 cdddr(v) = alloc(NIL, NIL);
 }
 }
 Cdr[y] = eval(cadr(m));
 unsave(1);
 return y;
}

(eval expression) ----> form

z_eval() 函数只返回传递给它的表达式以供进一步归约. 因此 ((lambda (x) (x x)) (lambda (x) (eval '(x x)))) 在常数空间内归约.

int z_eval(int n, int *pcf, int *pmode, int *pcbn) {
 int m;

 *pcf = 1;
 USE(pmode);
 *pcbn = 0;
 m = Cdr[n];
 if (m == NIL || Cdr[m] != NIL) return wrong_arg_count(n);
 return (Car[m]);
}

以下函数处理闭包生成. 它们由 lambda 特殊形式使用.

is_bound() 函数检查符号 n 在当前上下文中是否被绑定. 上下文由变量 Bound_vars (包含一个 (可能不当的) 变量列表) 和 Car[Lexical_env] (持有到目前为止构建的词法环境) 指定. Is_bound() 返回一个指示变量是否被绑定的标志.

int is_bound(int n) {
 int b;

 b = Bound_vars;
 while (b != NIL) {
 if (symbolic(b)) {
 if (n == b) return 1;
 break;
 }
 if (n == Car[b]) return 1;
 b = Cdr[b];
 }
 b = Car[Lexical_env];
 while (b != NIL) {
 if (caar(b) == n) return 1;
 b = Cdr[b];
 }
 return 0;
}

collect_free_vars() 收集 lambda 表达式的自由变量. 这个函数期望在 Lexical_env 的 car 字段中有一个空环境, 在 Bound_vars 中有一个绑定变量的列表. 它不返回任何东西, 但在 Car[Lexical_env] 中构建词法环境.

该函数不遍历以关键字 quote 开头的表达式. 为此, 仅仅检查 Car[n] == S_quote 是不够的, 因为这样做也会捕获像 (list quote foo) 这样的表达式. 通过检查 caar(n), 它确保 quote 实际上在 car 位置. 注意: 这也阻止了 (quote . {internal quote}) 被包含, 但谁又想重新定义 quote 呢？

void collect_free_vars(int n) {
 if (n == NIL || (Tag[n] & ATOM_FLAG)) return;
 if (symbolic(n)) {
 if (is_bound(n)) return;
 Car[Lexical_env] = alloc(NIL, Car[Lexical_env]);
 caar(Lexical_env) = alloc(n, Car[n] == Cdr[n]? n: Cdr[n]);
 return;
 }
 if (atomic(Car[n]) || caar(n) != S_quote)
 collect_free_vars(Car[n]);
 collect_free_vars(Cdr[n]);
}

以下函数为闭包创建一个词法环境 (又名词法上下文). 仅仅捕获当前环境是不够的, 因为解释器使用浅绑定, 值直接存储在符号中. Make_lexical_env() 遍历函数项 term 并收集其中包含的所有自由变量. Locals 是要转换为闭包的 lambda 形式的参数列表. 局部变量不被收集, 因为它们由 lambda 绑定.

int make_lexical_env(int term, int locals) {
 Lexical_env = alloc(NIL, NIL);
 save(Lexical_env);
 Bound_vars = locals;
 collect_free_vars(term);
 unsave(1);
 return Car[Lexical_env];
}

将一个 lambda 形式转换为一个闭包:

(lambda (symbol ...) expression)
----> (closure (symbol ...) expression alist)

将闭包的环境保存在 Env_stack 上, 以便可以由 fix_cached_closures() 修复.

int make_closure(int n) {
 int cl, env, args, term;

 if (Error_flag) return NIL;
 args = cadr(n);
 term = caddr(n);
 if (cdddr(n) == NIL) {
 env = make_lexical_env(term, args);
 if (env != NIL) {
 if (Env_stack != NIL)
 Env_stack = alloc(env, Env_stack);
 cl = alloc(env, NIL);
 }
 else {
 cl = NIL;
 }
 }
 else {
 cl = alloc(cadddr(n), NIL);
 }
 cl = alloc(term, cl);
 cl = alloc(args, cl);
 cl = alloc(S_closure, cl);
 return cl;
}

(lambda (symbol ...) expression) ----> {closure ...}

int z_lambda(int n, int *pcf, int *pmode, int *pcbn) {
 int m;

 m = Cdr[n];
 if ( m == NIL || Cdr[m] == NIL ||
 (cddr(m) != NIL && cdddr(m) != NIL)
 )
 return wrong_arg_count(n);
 if (cddr(m) != NIL && !is_alist(caddr(m)))
 return error("lambda: bad environment",
 caddr(m));
 if (!symbolic(Car[m]) && !is_list_of_symbols(Car[m]))
 return bad_argument_list(Car[m]);
 return Car[n] == S_closure? n: make_closure(n);
}

unbind_args() 函数由求值器用于恢复当前函数调用者的调用帧. 它恢复帧指针 (Frame)、当前活动函数的名称 (Function_name) 和当前帧中绑定的所有符号的外部值.

void unbind_args(void) {
 int v;

 Frame = unsave(1);
 Function_name = unsave(1);
 v = bunsave(1);
 while (v != NIL) {
 cdar(v) = unsave(1);
 v = Cdr[v];
 }
}

下一个函数为 let 和 letrec 特殊形式的归约设置一个上下文. 该函数将完整的特殊形式、环境的附加副本、一个 (最初为空的) 要重新绑定的符号列表和一个空的内部绑定集保存在 Bind_stack 上. 它还将 Env_stack 保存在 Stack 上并创建一个空的 Env_stack. 它返回要处理的环境 (特殊形式的第一个参数).

int let_setup(int n) {
 int m;

 m = Cdr[n];
 if (m == NIL || Cdr[m] == NIL || cddr(m) != NIL)
 return wrong_arg_count(n);
 m = Car[m];
 if (symbolic(m))
 return error("let/letrec: bad environment", m);
 bsave(n); /* save entire LET/LETREC */
 bsave(m); /* save environment */
 bsave(NIL); /* list of bindings */
 bsave(NIL); /* save empty name list */
 save(Env_stack); /* get outer bindings out of the way */
 Env_stack = NIL;
 return m;
}

处理 let/letrec 的一个绑定. 将当前绑定添加到新绑定的列表中, 并将其从 Bind_stack 的环境中移除. 返回环境的其余部分. 当此函数返回 () 时, 所有绑定都已处理完毕.

int let_next_binding(int n) {
 int m, p;

 m = caddr(Bind_stack); /* rest of environment */
 if (m == NIL) return NIL;
 p = Car[m];
 Tmp2 = n;
 cadr(Bind_stack) = alloc(NIL, cadr(Bind_stack));
 caadr(Bind_stack) = alloc(Car[p], n);
 Tmp2 = NIL;
 caddr(Bind_stack) = Cdr[m];
 return Cdr[m];
}

求值 let/letrec 的一个参数. 从保存在 Bind_stack 上的环境中获取一个绑定并检查其语法. 如果语法错误, 清理上下文并退出. 如果绑定格式正确, 将其变量 (car 字段) 保存在 Bind_stack 的名称列表中, 并返回关联的表达式 (cadr 字段) 以供归约.

int let_eval_arg(void) {
 int m, p, v;

 m = caddr(Bind_stack);
 p = Car[m];
 if ( atomic(p) || Cdr[p] == NIL || atomic(Cdr[p]) ||
 cddr(p) != NIL || !symbolic(Car[p])
 ) {
 /* Error, get rid of the partial environment. */
 v = bunsave(1);
 bunsave(3);
 bsave(v);
 Env_stack = unsave(1);
 save(Function_name);
 save(Frame);
 unbind_args();
 return error("let/letrec: bad binding", p);
 }
 Car[Bind_stack] = alloc(Car[p], Car[Bind_stack]);
 return cadr(p);
}

就地反转一个列表 (覆盖原始列表).

int reverse_in_situ(int n) {
 int this, next, x;

 if (n == NIL) return NIL;
 this = n;
 next = Cdr[n];
 Cdr[this] = NIL;
 while (next != NIL) {
 x = Cdr[next];
 Cdr[next] = this;
 this = next;
 next = x;
 }
 return this;
}

建立 let/letrec 的绑定. 在 Stack 上保存外部值.

void let_bind(int env) {
 int b;

 while (env != NIL) {
 b = Car[env];
 save(cdar(b)); /* Save old value */
 cdar(b) = Cdr[b]; /* Bind new value */
 env = Cdr[env];
 }
}

完成 let/letrec 的局部绑定创建. 首先从 Bind_stack 将上下文加载到局部变量中并清理 Bind_stack. 然后执行实际的绑定, 在 Stack 上保存外部值. 在 Bind_stack 上保存一个局部符号列表, 以便稍后可以恢复它们. 如果此函数处理一个 letrec 特殊形式 (rec set), 修复缓存的词法环境. 最后返回绑定构造的项以供进一步归约.

这个函数在 Bind_stack 和 Stack 上留下了与 lambda 相同的调用帧.

int let_finish(int rec) {
 int m, v, b, e;

 Tmp2 = alloc(NIL, NIL); /* Create safe storage */
 Cdr[Tmp2] = alloc(NIL, NIL);
 cddr(Tmp2) = alloc(NIL, NIL);
 cdddr(Tmp2) = alloc(NIL, NIL);
 v = bunsave(1);
 b = bunsave(1); /* bindings */
 m = bunsave(2); /* drop environment, get full LET/LETREC */
 b = reverse_in_situ(b); /* needed for UNBINDARGS() */
 e = unsave(1);
 Car[Tmp2] = b;
 cadr(Tmp2) = m;
 caddr(Tmp2) = v;
 cdddr(Tmp2) = e;
 let_bind(b);
 bsave(v);
 if (rec) fix_cached_closures();
 Env_stack = e;
 save(Function_name);
 save(Frame);
 Tmp2 = NIL;
 return caddr(m); /* term */
}

(let ((symbol expression1) ...) expressionn) ----> form

int z_let(int n, int *pcf, int *pmode, int *pcbn) {
 *pcf = 2;
 *pmode = MBIND;
 USE(pcbn);
 if (let_setup(n) != NIL)
 return let_eval_arg();
 else
 return NIL;
}

(letrec ((symbol expression1) ...) expressionn) ----> form

int z_letrec(int n, int *pcf, int *pmode, int *pcbn) {
 int m;

 *pcf = 2;
 *pmode = MBINR;
 USE(pcbn);
 if (let_setup(n) != NIL)
 m = let_eval_arg();
 else
 m = NIL;
 Env_stack = S_true;
 return m;
}

(or expression ...) ----> form

int z_or(int n, int *pcf, int *pmode, int *pcbn) {
 USE(pcbn);
 if (Cdr[n] == NIL) {
 return S_false;
 }
 else if (cddr(n) == NIL) {
 *pcf = 1;
 return cadr(n);
 }
 else {
 *pcf = 2;
 *pmode = MDISJ;
 return setup_and_or(n);
 }
}

(quote form) ----> form

int z_quote(int n, int *pcf, int *pmode, int *pcbn) {
 int m;

 USE(pcf);
 USE(pmode);
 USE(pcbn);
 m = Cdr[n];
 if (m == NIL || Cdr[m] != NIL) return wrong_arg_count(n);
 return (Car[m]);
}

(closure-form :t | :f) ----> :t | :f

int z_closure_form(int n, int *pcf, int *pmode, int *pcbn) {
 int m;

 USE(pcf);
 USE(pmode);
 USE(pcbn);
 m = Cdr[n];
 if (m == NIL || Cdr[m] != NIL) return wrong_arg_count(n);
 if (!symbolic(Car[m]))
 return error("closure-form: got non-symbol", Car[m]);
 if (Car[m] == add_symbol("args", S_void))
 Closure_form = 0;
 else if (Car[m] == add_symbol("body", S_void))
 Closure_form = 1;
 else if (Car[m] == add_symbol("env", S_void))
 Closure_form = 2;
 else
 return S_false;
 return Car[m];
}

在转储映像文件时保存这些变量.

int *Image_vars[] = {
 &Closure_form, &Verify_arrows,
 &Symbols, &Freelist, &S_bottom, &S_closure, &S_false,
 &S_lambda, &S_primitive, &S_quote, &S_special,
 &S_special_cbv, &S_true, &S_void, &S_last,
 NULL };

将一个节点池映像写入给定文件. 当映像无法创建或写入成功时, 报告一个错误.

int dump_image(char *p) {
 int fd, n, i;
 int **v;
 char magic;

 fd = open(p, O_CREAT | O_WRONLY, 0644);
 setmode(fd, O_BINARY);
 if (fd < 0) {
 error("cannot create file", NO_EXPR);
 Error.arg = p;
 return -1;
 }
 strcpy(magic, "ZEN_____________");
 magic = sizeof(int);
 magic = VERSION;
 n = 0x12345678;
 memcpy(&magic, &n, sizeof(int));
 write(fd, magic, 16);
 n = Pool_size;
 write(fd, &n, sizeof(int));
 v = Image_vars;
 i = 0;
 while (v[i]) {
 write(fd, v[i], sizeof(int));
 i = i+1;
 }
 if ( write(fd, Car, Pool_size*sizeof(int))
 != Pool_size*sizeof(int) ||
 write(fd, Cdr, Pool_size*sizeof(int))
 != Pool_size*sizeof(int) ||
 write(fd, Tag, Pool_size) != Pool_size
 ) {
 error("dump failed", NO_EXPR);
 close(fd);
 return -1;
 }
 close(fd);
 return 0;
}

(dump-image symbol) ----> :t

int z_dump_image(int n, int *pcf, int *pmode, int *pcbn) {
 int m;
 static char buf[SYMBOL_LEN], *s;

 USE(pcf);
 USE(pmode);
 USE(pcbn);
 m = Cdr[n];
 if (m == NIL || Cdr[m] != NIL) return wrong_arg_count(n);
 if (!symbolic(Car[m]))
 return error("dump-image: got non-symbol",
 Car[m]);
 s = symbol_to_string(Car[m], buf, SYMBOL_LEN);
 if (s) dump_image(s);
 return S_true;
}

以下函数由 load 特殊形式使用. Get_source_dir() 将文件路径的目录部分提取到一个缓冲区中. 当文件路径没有目录部分时, 缓冲区被填充为 ".".

void get_source_dir(char *path, char *buf) {
 char *p;

 if (strlen(path) > 256) {
 error("load: path too long", NO_EXPR);
 return;
 }
 strcpy(buf, path);
 p = strrchr(buf, '/');
 if (p == NULL)
 strcpy(buf, ".");
 else
 *p = 0;
}

通过将路径复制到缓冲区并用 $ZENSRC/ (ZENSRC 环境变量的值和一个斜杠) 替换副本中的波浪号来展开以 "~" 开头的路径名. 当 ZENSRC 未定义时, 只返回原始路径.

/* Expand leading ~ in path names */
char *expand_path(char *s, char *buf) {
 char *r, *v;

 if (s == '~')
 r = &s;
 else
 return s;
 if ((v = getenv("ZENSRC")) == NULL) return s;
 if (strlen(v) + strlen(r) + 4 >= MAX_PATH_LEN) {
 error("load: path too long", NO_EXPR);
 return s;
 }
 sprintf(buf, "%s/%s", v, r);
 return buf;
}

加载一个 zenlisp 源文件. 从文件中读取表达式并将其传递给求值器. Load() 使用 Load_level 跟踪嵌套加载. 当从文件中加载文件时, 将对嵌套加载使用相同的源路径.

注意: 这里使用的方法是有问题的, 因为它在离开目录时不会恢复源路径. 欢迎修复.

int load(char *p) {
 FILE *ofile, *nfile;
 int r;
 char *oname;
 char *arg;
 int oline;

 arg = p;
 if (Load_level > 0) {
 if (strlen(p) + strlen(Source_dir) + 4 >= MAX_PATH_LEN) {
 error("load: path too long", NO_EXPR);
 return -1;
 }
 if (*p != '.' && *p != '/' && *p != '~')
 sprintf(Current_path, "%s/%s", Source_dir, p);
 else
 strcpy(Current_path, p);
 p = Current_path;
 }
 p = expand_path(p, Expanded_path);
 get_source_dir(p, Source_dir);
 strcat(p, ".l");
 if ((nfile = fopen(p, "r")) == NULL) {
 error("cannot open source file", NO_EXPR);
 Error.arg = arg;
 return -1;
 }
 Load_level = Load_level + 1;
 /* Save I/O state and redirect */
 r = Rejected;
 ofile = Input;
 Input = nfile;
 oline = Line;
 Line = 1;
 oname = Infile;
 Infile = p;
 read_eval_loop();
 Infile = oname;
 Line = oline;
 /* Restore previous I/O state */
 Rejected = r;
 Input = ofile;
 Load_level = Load_level - 1;
 fclose(nfile);
 if (Paren_level) error("unbalanced parentheses in loaded file",
 NO_EXPR);
 return 0;
}

(load symbol) ----> :t

int z_load(int n, int *pcf, int *pmode, int *pcbn) {
 int m;
 char buf[SYMBOL_LEN+1], *s;

 USE(pcf);
 USE(pmode);
 USE(pcbn);
 m = Cdr[n];
 if (m == NIL || Cdr[m] != NIL) return wrong_arg_count(n);
 if (!symbolic(Car[m])) return error("load: got non-symbol", Car[m]);
 s = symbol_to_string(Car[m], buf, SYMBOL_LEN);
 if (s) {
 s = strdup(s);
 if (s == NULL) fatal("load: strdup() failed");
 load(s);
 free(s);
 }
 return S_true;
}

(stats expression) ----> '(form reductions allocations collections)

int z_stats(int n, int *pcf, int *pmode, int *pcbn) {
 int m;
 char buf;

 USE(pcf);
 USE(pmode);
 USE(pcbn);
 m = Cdr[n];
 if (m == NIL || Cdr[m] != NIL) return wrong_arg_count(n);
 reset_counter(&Allocations);
 reset_counter(&Reductions);
 reset_counter(&Collections);
 Stat_flag = 1;
 n = eval(Car[m]);
 Stat_flag = 0;
 n = alloc(n, NIL);
 save(n);
 Cdr[n] = alloc(NIL, NIL);
 cadr(n) = explode_string(counter_to_string(&Reductions, buf));
 cddr(n) = alloc(NIL, NIL);
 caddr(n) = explode_string(counter_to_string(&Allocations, buf));
 cdddr(n) = alloc(NIL, NIL);
 cadddr(n) = explode_string(counter_to_string(&Collections, buf));
 unsave(1);
 return n;
}

(trace symbol) ----> :t
(trace) ----> :t

int z_trace(int n, int *pcf, int *pmode, int *pcbn) {
 int m;
 static char buf[SYMBOL_LEN], *s;

 USE(pcf);
 USE(pmode);
 USE(pcbn);
 m = Cdr[n];
 if (m == NIL) {
 Traced_fn = NIL;
 return S_true;
 }
 if (Cdr[m] != NIL) return wrong_arg_count(n);
 if (!symbolic(Car[m])) return error("trace: got non-symbol", Car[m]);
 s = symbol_to_string(Car[m], buf, SYMBOL_LEN);
 if (!s) return S_false;
 Traced_fn = find_symbol(s);
 return S_true;
}

如果 Car[np] 是一个关键字, 运行相应的特殊形式处理程序, 将 np 设置为操作的结果, 并返回 1. 如果 Car[np] 不是一个关键字, 返回 0.

int special(int *np, int *pcf, int *pmode, int *pcbn) {
 int n, y;
 int (*op)(int, int *, int *, int *);

 n = np;
 y = Car[n];
 if (Error_flag) return 0;
 if (Car[y] == S_special || Car[y] == S_special_cbv)
 op = Specials[cadr(y)];
 else if (symbolic(y) &&
 (cadr(y) == S_special ||
 cadr(y) == S_special_cbv)
 )
 op = Specials[caddr(y)];
 else
 return 0;
 np = (*op)(n, pcf, pmode, pcbn);
 return 1;
}

3.1.10. 12.10 求值器

bind_args() 函数将 lambda 函数 (闭包) 的变量绑定到一些实际参数: 对于 i in ((lambda (v1 … vb) x) a1 … an),

将 vi 添加到 Car[Bind_stack] (最初为空);
在 Stack 上保存 vi 的值;
将 vi 绑定到 ai.

同时保存并更新函数名和调用帧指针.

因为使用了浅绑定, 每个变量的外部值在重新绑定该变量之前必须被保存, 并在函数上下文不再存在时恢复. 这种方法可能看起来效率低下, 但它使变量查找成为一个单一的间接操作.

void bind_args(int n, int name) {
 int fa, /* formal arg list */
 aa, /* actual arg list */
 e; /* term */
 int env; /* optional lexical environment */
 int p;
 int at; /* atomic argument list flag */

 if (Error_flag) return;
 fa = cadar(n);
 at = symbolic(fa);
 aa = Cdr[n];
 p = cddar(n);
 e = Car[p];
 env = Cdr[p] != NIL ? cadr(p): NIL;
 bsave(NIL); /* names */
 while ((fa != NIL && aa != NIL) || at) {
 if (!at) {
 Car[Bind_stack] = alloc(Car[fa], Car[Bind_stack]);
 save(cdar(fa));
 cdar(fa) = Car[aa];
 fa = Cdr[fa];
 aa = Cdr[aa];
 }
 if (symbolic(fa)) {
 Car[Bind_stack] = alloc(fa, Car[Bind_stack]);
 save(Cdr[fa]);
 Cdr[fa] = aa;
 fa = NIL;
 aa = NIL;
 break;
 }
 }
 while (env != NIL) {
 p = Car[env];
 Car[Bind_stack] = alloc(Car[p], Car[Bind_stack]);
 save(cdar(p));
 cdar(p) = Cdr[p];
 env = Cdr[env];
 }
 if (fa != NIL || aa != NIL) {
 wrong_arg_count(n);
 n = NIL;
 }
 else {
 n = e;
 }
 save(Function_name);
 Function_name = name;
 save(Frame);
 Frame = Stack;
}

打印正在跟踪的函数调用:

+ (function argument ...)

void print_trace(int n) {
 pr("+ ");
 pr("(");
 Quotedprint = 1;
 print(Traced_fn);
 while (1) {
 n = Cdr[n];
 if (n == NIL) break;
 pr(" ");
 print(Car[n]);
 }
 pr(")"); nl();
}

eliminate_tail_calls() 函数检查 Mode_stack 以找出当前函数在 MBETA 状态下的调用者. 如果是, 对当前函数的调用是一个尾调用. 在这种情况下, eliminate_tail_calls() 从 Stack 和 Mode_stack 中移除调用者的所有 let, letrec 和 lambda 帧.

void eliminate_tail_calls(void) {
 int m, y;

 m = Car[Mode_stack];
 /* Skip over callee’s local frames, if any */
 while (m != NIL && Car[m] == MLETR) {
 m = Cdr[m];
 }
 /* Parent not beta-reducing? Give up. */
 if (m == NIL || Car[m] != MBETA)
 return;
 /* Yes, this is a tail call: */
 /* remove callee’s frames. */
 while (1) {
 Tmp2 = unsave(1); /* M */
 unbind_args();
 unsave(1);
 y = munsave();
 save(Tmp2);
 Tmp2 = NIL;
 if (y == MBETA) break;
 }
}

eval() 函数是 zenlisp 解释器的核心. 它将一个表达式归约为其范式并返回它. 当由它求值的程序在常数空间内运行时, 该函数保证在常数空间内运行. 因为 eval() 有点长 (多页), 注释文本穿插在函数中. 代码的第一个块保存并重置当前的解释器状态.

int eval(int n) {
 int m, /* Result node */
 m2, /* Root of result lists */
 a; /* Used to append to result */
 int mode, /* Current state */
 cf, /* Continue flag */
 cbn; /* Call by name flag */
 int nm; /* Name of function to apply */

 Eval_level = Eval_level + 1;
 save(n);
 save(Arg_stack);
 save(Bind_stack);
 save(Car[Mode_stack]);
 save(Stack_bottom);
 Stack_bottom = Stack;
 mode = MATOM;
 cf = 0;
 cbn = 0;

在以下循环中, n 持有一个源表达式 (可能由一个特殊形式生成), m 最终持有相应的范式.

while (!Error_flag) {
if (Stat_flag) count(&Reductions, 1);
if (n == NIL) { /* () -> () */
m = NIL;
cbn = 0;
}
else if (symbolic(n)) { /* Symbol -> Value */
if (cbn) {
m = n;
cbn = 0;
}
else {
m = Cdr[n] == Car[n]? n: Cdr[n];
if (m == S_void) {
error("symbol not bound", n);
break;
}
}
}

黑客警报！当 cbn “标志”设置为 2 时, 这意味着“根本不求值这个表达式”, 而不仅仅是“按名称调用”. 因此, cbn==2 可以被认为是 cbn==1 的“更强”形式.

else if (Car[n] == S_closure ||
Car[n] == S_primitive ||
Car[n] == S_special ||
Car[n] == S_special_cbv ||
cbn == 2
) {
m = n;
cbn = 0;
}

以下分支用于下降到一个列表中. 它将各种值保存在栈上, 以便后续循环处理. 保存的值是:

原始源列表 (在 Stack 上);
当前状态 (在 Mode_stack 上);
结果列表 (由后续循环填充, 在 Arg_stack 上);
用于向结果列表附加值的指针 (在 Arg_stack 上);
剩余要求值的成员 (在 Arg_stack 上).

当使用传值调用时, 结果列表将用 (()) 初始化, 附加指针 a 将指向同一个形式. 要附加一个范式 x, 只需将其存储在 Car[a] 中就足够了. 然后一个新的空列表存储在 Cdr[a] 中, a 前进到 cdr 部分. 所以附加元素是一个 O(1) 操作.

当使用传名调用时, 结果列表是源列表的副本, 剩余成员列表设置为空 ().

else { /* List (...) and Pair (X.Y) */
m = Car[n];
save(n);
msave(mode);
if ((symbolic(m) && cadr(m) == S_special) || cbn) {
cbn = 0;
asave(NIL);
asave(NIL);
asave(n); /* Root of result list */
n = NIL;
}
else {
a = alloc(NIL, NIL);
asave(a);
asave(Cdr[n]);
asave(a); /* Root of result list */
n = Car[n];
}
mode = MLIST;
continue;
}

以下循环求值一个列表的成员, 执行函数应用并归约特殊形式. 注意, while 循环的缩进是错误的. 循环体跨越了 100 多行. 你将在循环的末尾找到一个余数.

在 MBETA 状态下, 剩下的就是清理调用函数的上下文并返回到外部列表 (如果有的话).

while (1) if (mode == MBETA || mode == MLETR) {
/* Finish BETA reduction */
unbind_args();
unsave(1);
mode = munsave();
}

在 MLIST 模式下, 列表的成员被归约为它们的范式.

else if (mode == MLIST) {
n = cadr(Arg_stack); /* Next member */
a = caddr(Arg_stack); /* Place to append to */
m2 = aunsave(1); /* Root of result list */

好了, 得到一个完整的列表, 现在决定做什么.

if (a != NIL) Car[a] = m;
if (n == NIL) { /* End of list */
m = m2;
aunsave(2); /* Drop N,A */
nm = Car[unsave(1)];
save(m); /* Save result */
if (Traced_fn == nm) print_trace(m);
if (primitive(&m))
;
else if (special(&m, &cf, &mode, &cbn))
n = m;
else if (!atomic(Car[m]) &&
caar(m) == S_closure
) {
nm = symbolic(nm)? nm: NIL;
eliminate_tail_calls();
bind_args(m, nm);
/* N=E of ((LAMBDA (...) E) ...) */
n = caddar(m);
cf = 2;
mode = MBETA;
}
else {
error("application of non-function",
nm);
n = NIL;
}

另一个“标志”黑客. Cf==2 意味着当前上下文还不能被放弃, 因为当前求值仍在进行中. 这只在求值 lambda 的项时发生函数. 在这种情况下, 通过设置 mode=MBETA 来执行清理.

if (cf != 2) {
unsave(1);
mode = munsave();
}
/* Leave the list loop and re-evaluate N */
if (cf) break;
}

列表尚未到达末尾, 插入当前成员, 附加新的空槽, 并准备下一个成员以供求值.

else { /* N =/= NIL: Append to list */
asave(m2);
Cdr[a] = alloc(NIL, NIL);
caddr(Arg_stack) = Cdr[a];
cadr(Arg_stack) = Cdr[n];
if (symbolic(n))
error("improper list in application",
n);
n = Car[n]; /* Evaluate next member */
break;
}
}

这里是处理绑定构造和控制流构造的地方. 这仍然是列表求值循环的一部分.

这个分支求值 cond 表达式.

else if (mode == MCOND) {
n = cond_eval_clause(m);
if (Car[Bind_stack] == NIL) {
unsave(1);
bunsave(1);
mode = munsave();
}
cf = 1;
break;
}

求值 and 和 or.

else if (mode == MCONJ || mode == MDISJ) {
Car[Bind_stack] = cdar(Bind_stack);
if ( (m == S_false && mode == MCONJ) ||
(m != S_false && mode == MDISJ) ||
Car[Bind_stack] == NIL
) {
unsave(1);
bunsave(1);
mode = munsave();
n = m;
cbn = 2;
}
else if (cdar(Bind_stack) == NIL) {
n = caar(Bind_stack);
unsave(1);
bunsave(1);
mode = munsave();
}
else {
n = caar(Bind_stack);
}
cf = 1;
break;
}

求值 let 和 letrec.

else if (mode == MBIND || mode == MBINR) {
if (let_next_binding(m) == NIL) {
n = let_finish(mode == MBINR);
mode = MLETR;
}
else {
n = let_eval_arg();
}
cf = 1;
break;
}

如果要求值的表达式是一个原子, 那么就没什么可做的了.

else { /* Atom */
break;
}

列表求值循环到此结束.

if (cf) { /* Continue evaluation if requested */
cf = 0;
continue;
}
if (Stack == Stack_bottom) break;
}

恢复解释器的前一个状态.

 while (Stack != Stack_bottom) unsave(1);
 Stack_bottom = unsave(1);
 Car[Mode_stack] = unsave(1);
 Bind_stack = unsave(1);
 Arg_stack = unsave(1);
 unsave(1);
 Eval_level = Eval_level - 1;
 return m;
}

3.1.11. 12.11 打印机

在 print() 之前的辅助函数都以相同的方式工作. 它们检查它们的参数是否具有特定的属性, 如果有, 它们就打印该参数并返回 1. 否则返回 0.

将 (quote x) 打印为 'x.

int print_quoted_form(int n, int dot) {
 if ( Car[n] == S_quote &&
 Cdr[n] != NIL &&
 cddr(n) == NIL
 ) {
 if (dot) pr(" . ");
 n = cadr(n);
 if (n != S_true && n != S_false) pr("'");
 print(n);
 return 1;
 }
 return 0;
}

将单字符符号的列表打印为压缩列表.

int print_condensed_list(int n, int dot) {
 int m;
 char s;

 m = n;
 if (m == NIL) return 0;
 while (m != NIL) {
 if (!symbolic(Car[m])) return 0;
 if (cdaar(m) != NIL) return 0;
 m = Cdr[m];
 }
 if (dot) pr(" . ");
 pr("#");
 m = n;
 s = 0;
 while (m != NIL) {
 s = caaar(m);
 pr(s);
 m = Cdr[m];
 }
 return 1;
}

打印闭包. Closure_form 变量决定了打印多少信息. 注意, 当没有环境被打印时, 闭包是有歧义的. 因此, 当 Closure_form 小于 2 时, 此函数打印 {closure …} 而不是 (closure …).

int print_closure(int n, int dot) {
 if ( Car[n] == S_closure &&
 !atomic(Cdr[n]) &&
 !atomic(cddr(n))
 ) {
 Quotedprint = 1;
 if (dot) pr(" . ");
 pr(Closure_form==2? "(closure ": "{closure ");
 print(cadr(n));
 if (Closure_form > 0) {
 pr(" ");
 print(caddr(n));
 if (Closure_form > 1 && cdddr(n) != NIL) {
 pr(" ");
 print(cadddr(n));
 }
 }
 pr(Closure_form==2? ")": "}");
 return 1;
 }
 return 0;
}

打印原始函数处理程序和特殊形式处理程序.

int print_primitive(int n, int dot) {
 if ( Car[n] != S_primitive &&
 Car[n] != S_special &&
 Car[n] != S_special_cbv
 )
 return 0;
 if (dot) pr(" . ");
 pr("{internal ");
 Quotedprint = 1;
 print(cddr(n));
 pr("}");
 return 1;
}

这是 zenlisp 打印机接口. 它将形式的内部节点表示转换为其外部 (人类可读的) 形式并发射它.

void print(int n) {
 char s[SYMBOL_LEN+1];
 int i;

 if (n == NIL) {
 pr("()");
 }
 else if (n == S_void) {
 pr("{void}");
 }
 else if (Tag[n] & ATOM_FLAG) {
 /* Characters are limited to the symbol table */
 pr("{unprintable form}");
 }
 else if (symbolic(n)) {
 if (!Quotedprint && n != S_true && n != S_false) {
 pr("'");
 Quotedprint = 1;
 }
 i = 0; /* Symbol */
 n = Car[n];
 while (n != NIL) {
 s[i] = Car[n];
 if (i > SYMBOL_LEN-2) break;
 i += 1;
 n = Cdr[n];
 }
 s[i] = 0;
 pr(s);
 }
 else { /* List */
 if (print_closure(n, 0)) return;
 if (print_primitive(n, 0)) return;
 if (!Quotedprint) {
 pr("'");
 Quotedprint = 1;
 }
 if (print_quoted_form(n, 0)) return;
 if (print_condensed_list(n, 0)) return;
 pr("(");
 while (n != NIL) {
 print(Car[n]);
 n = Cdr[n];
 if (symbolic(n) || n == S_void) {
 pr(" . ");
 print(n);
 n = NIL;
 }
 if (print_closure(n, 1)) break;
 if (print_primitive(n, 1)) break;
 if (print_quoted_form(n, 1)) break;
 if (n != NIL) pr(" ");
 }
 pr(")");
 }
}

3.1.12. 12.12 初始化

重置解释器的状态: 清除栈和调试变量, 并重置级别计数器.

void reset_state(void) {
 Stack = NIL;
 Arg_stack = NIL;
 Bind_stack = NIL;
 Env_stack = NIL;
 Frame = NIL;
 Function_name = NIL;
 Eval_level = 0;
 Paren_level = 0;
}

解释器初始化的第一阶段. 初始化杂项变量, 清除空闲列表, 连接输入/输出流.

void init1() {
 /* Misc. variables */
 reset_state();
 Mode_stack = NIL;
 Error_flag = 0;
 Error.arg = NULL;
 Fatal_flag = 0;
 Symbols = NIL;
 Safe_symbols = NIL;
 Tmp_car = NIL;
 Tmp_cdr = NIL;
 Tmp = NIL;
 Tmp2 = NIL;
 Load_level = 0;
 Traced_fn = NIL;
 Max_atoms_used = 0;
 Max_trace = 10;
 Stat_flag = 0;
 Closure_form = 0;
 Verify_arrows = 0;
 Line = 1;
 /* Initialize Freelist */
 Freelist = NIL;
 /* Clear input buffer */
 Infile = NULL;
 Source_dir = 0;
 Input = stdin;
 Output = stdout;
 Rejected = EOT;
}

解释器初始化的第二阶段: 构建空闲列表, 创建内置符号.

void init2(void) {
 /*
 * Tags (especially 'primitive and 'special*)
 * must be defined before the primitives.
 * First GC will be triggered HERE
 */
 S_void = add_symbol("{void}", 0);
 S_special = add_symbol("{special}", 0);
 S_special_cbv = add_symbol("{special/cbv}", 0);
 S_primitive = add_symbol("{primitive}", 0);
 S_closure = add_symbol("closure", 0);
 add_primitive("atom", P_ATOM);
 add_special("and", SF_AND, 0);
 add_special("apply", SF_APPLY, 1);
 S_bottom = add_primitive("bottom", P_BOTTOM);
 add_primitive("car", P_CAR);
 add_primitive("cdr", P_CDR);
 add_special("closure-form", SF_CLOSURE_FORM, 0);
 add_special("cond", SF_COND, 0);
 add_primitive("cons", P_CONS);
 add_special("define", SF_DEFINE, 0);
 add_primitive("defined", P_DEFINED);
 add_special("dump-image", SF_DUMP_IMAGE, 0);
 add_special("eval", SF_EVAL, 1);
 add_primitive("eq", P_EQ);
 add_primitive("explode", P_EXPLODE);
 S_false = add_symbol(":f", 0);
 add_primitive("gc", P_GC);
 add_primitive("implode", P_IMPLODE);
 S_lambda = add_special("lambda", SF_LAMBDA, 0);
 add_special("let", SF_LET, 0);
 add_special("letrec", SF_LETREC, 0);
 add_special("load", SF_LOAD, 0);
 add_special("or", SF_OR, 0);
 add_primitive("quit", P_QUIT);
 S_quote = add_special("quote", SF_QUOTE, 0);
 add_primitive("recursive-bind", P_RECURSIVE_BIND);
 add_special("stats", SF_STATS, 0);
 add_primitive("symbols", P_SYMBOLS);
 S_true = add_symbol(":t", 0);
 add_symbol("t", S_true);
 add_special("trace", SF_TRACE, 0);
 add_primitive("verify-arrows", P_VERIFY_ARROWS);
 S_last = add_symbol("**", 0);
 Mode_stack = alloc(NIL, NIL);
 Primitives[P_ATOM] = &z_atom;
 Primitives[P_BOTTOM] = &z_bottom;
 Primitives[P_CAR] = &z_car;
 Primitives[P_CDR] = &z_cdr;
 Primitives[P_CONS] = &z_cons;
 Primitives[P_DEFINED] = &z_defined;
 Primitives[P_EQ] = &z_eq;
 Primitives[P_EXPLODE] = &z_explode;
 Primitives[P_GC] = &z_gc;
 Primitives[P_IMPLODE] = &z_implode;
 Primitives[P_QUIT] = &z_quit;
 Primitives[P_RECURSIVE_BIND] = &z_recursive_bind;
 Primitives[P_SYMBOLS] = &z_symbols;
 Primitives[P_VERIFY_ARROWS] = &z_verify_arrows;
 Specials[SF_AND] = &z_and;
 Specials[SF_APPLY] = &z_apply;
 Specials[SF_CLOSURE_FORM] = &z_closure_form;
 Specials[SF_COND] = &z_cond;
 Specials[SF_DEFINE] = &z_define;
 Specials[SF_DUMP_IMAGE] = &z_dump_image;
 Specials[SF_EVAL] = &z_eval;
 Specials[SF_LAMBDA] = &z_lambda;
 Specials[SF_LET] = &z_let;
 Specials[SF_LETREC] = &z_letrec;
 Specials[SF_LOAD] = &z_load;
 Specials[SF_OR] = &z_or;
 Specials[SF_QUOTE] = &z_quote;
 Specials[SF_STATS] = &z_stats;
 Specials[SF_TRACE] = &z_trace;
}

清除统计计数器.

void clear_stats(void) {
 reset_counter(&Reductions);
 reset_counter(&Allocations);
 reset_counter(&Collections);
}

3.1.13. 12.13 解释器接口

从给定文件加载一个节点池映像. 成功时返回零, 失败时返回非零值.

int zen_load_image(char *p) {
 int fd, n, i;
 char buf;
 int **v;
 int bad = 0;
 int inodes;

 fd = open(p, O_RDONLY);
 setmode(fd, O_BINARY);
 if (fd < 0) {
 error("cannot open image", NO_EXPR);
 Error.arg = p;
 return -1;
 }
 memset(Tag, 0, Pool_size);
 read(fd, buf, 16);
 if (memcmp(buf, "ZEN____", 7)) {
 error("bad image (magic match failed)", NO_EXPR);
 bad = 1;
 }
 if (buf != sizeof(int)) {
 error("bad image (wrong cell size)", NO_EXPR);
 bad = 1;
 }
 if (buf != VERSION) {
 error("bad image (wrong version)", NO_EXPR);
 bad = 1;
 }
 memcpy(&n, &buf, sizeof(int));
 if (n != 0x12345678) {
 error("bad image (wrong architecture)", NO_EXPR);
 bad = 1;
 }
 read(fd, &inodes, sizeof(int));
 if (inodes > Pool_size) {
 error("bad image (too many nodes)", NO_EXPR);
 bad = 1;
 }
 v = Image_vars;
 i = 0;
 while (v[i]) {
 read(fd, v[i], sizeof(int));
 i = i+1;
 }
 if ( !bad &&
 (read(fd, Car, inodes*sizeof(int)) != inodes*sizeof(int) ||
 read(fd, Cdr, inodes*sizeof(int)) != inodes*sizeof(int) ||
 read(fd, Tag, inodes) != inodes)
 ) {
 error("bad image (bad file size)", NO_EXPR);
 bad = 1;
 }
 close(fd);
 if (bad) Error.arg = p;
 return Error_flag;
}

主初始化. 分配节点池, 清除标签, 初始化变量.

int zen_init(int nodes, int vgc) {
 Pool_size = nodes? nodes: DEFAULT_NODES;
 Verbose_GC = vgc;
 if (Pool_size < MINIMUM_NODES) return -1;
 if ( (Car = (int *) malloc(Pool_size * sizeof(int))) == NULL ||
 (Cdr = (int *) malloc(Pool_size * sizeof(int))) == NULL ||
 (Tag = (char *) malloc(Pool_size)) == NULL
 ) {
 if (Car) free(Car);
 if (Cdr) free(Cdr);
 if (Tag) free(Tag);
 Car = Cdr = NULL;
 Tag = NULL;
 return -1;
 }
 memset(Tag, 0, Pool_size);
 init1();
 init2();
 return 0;
}

释放节点池.

void zen_fini() {
 if (Car) free(Car);
 if (Cdr) free(Cdr);
 if (Tag) free(Tag);
 Car = Cdr = NULL;
 Tag = NULL;
}

在收到用户的“中断”信号 (SIGINT) 后停止解释器.

void zen_stop(void) {
 error("interrupted", NO_EXPR);
}

I/O 接口.

void zen_print(int n) {
 Quotedprint = 0;
 print(n);
}

int zen_read(void) {
 Paren_level = 0;
 return zread();
}

创建符号表的副本. 这个副本将保存在一个安全的位置 (Safe_symbols), 以便在出现严重错误时可以用来恢复符号表.

int copy_bindings(void) {
 int y, p, ny, q;

 p = alloc(NIL, NIL);
 save(p);
 ny = p;
 q = NIL;
 y = Symbols;
 while (y != NIL) {
 Car[p] = alloc(Car[y], cdar(y));
 y = Cdr[y];
 Cdr[p] = alloc(NIL, NIL);
 q = p;
 p = Cdr[p];
 }
 if (q != NIL) Cdr[q] = NIL;
 unsave(1);
 return Car[ny] == NIL? NIL: ny;
}

恢复由 copy_bindings() 保存的绑定.

void restore_bindings(int values) {
 int b;

 while (values != NIL) {
 b = Car[values];
 cdar(b) = Cdr[b];
 values = Cdr[values];
 }
}

安全地将一个表达式归约为其范式. 在出现错误时优雅地退出.

int zen_eval(int n) {
 save(n);
 Safe_symbols = copy_bindings();
 if (Stat_flag) clear_stats();
 n = eval(n, 0);
 unsave(1);
 if (!Error_flag) {
 Cdr[S_last] = n;
 if (Stack != NIL)
 fatal("eval(): unbalanced stack");
 }
 else {
 restore_bindings(Safe_symbols);
 }
 reset_state();
 while (Car[Mode_stack] != NIL) munsave();
 return n;
}

强制性的许可证文本.

char **zen_license() {
 static char *license_text[] = {
 "",
 "zenlisp -- An interpreter for symbolic LISP",
 "By Nils M Holm, 2007, 2008",
 "",
 "Don’t worry, be happy.",
 "",
 "THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ‘‘AS IS’’ AND",
 "ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE",
 "IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE",
 "ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE",
 "FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL",
 "DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS",
 "OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)",
 "HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT",
 "LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY",
 "OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF",
 "SUCH DAMAGE.",
 "",
 NULL};
 return license_text;
}

这是一个简单的内部读-求值循环 (没有打印). 它用于加载程序.

void read_eval_loop(void) {
 int n, evl;

 Error_flag = 0;
 evl = Eval_level;
 Eval_level = 0;
 while(!Error_flag) {
 n = zen_read();
 if (n == EOT) break;
 n = eval(n, 0);
 }
 Eval_level = evl;
}

3.1.14. 12.14 解释器 shell

zenlisp 解释器的用户界面从这里开始. 上下两部分代码之间只有很少的联系. 两个部分可以放在不同的文件中, 只需稍作修改. 这个头文件是处理键盘中断所必需的:

#include <signal.h>

Image 保存要加载的节点池映像的名称. Nodes 是要分配的节点池的大小. Batch 是一个标志, 指示解释器是否应在批处理模式下运行. 当 GC_stats 设置为 1 时, 解释器将在每次垃圾回收后打印一些信息.

在批处理模式下, 解释器将

不打印横幅或 => 运算符;
在报告错误后立即退出;
在捕获 SIGINT 时立即退出.

char Image[MAX_PATH_LEN];
int Nodes;
int Batch;
int GC_stats;

void usage(void) {
 fprintf(stderr,
 "Usage: zl [-L] [-bgi] [-n nodes] [image]\n");
}

检索与命令行选项关联的 (数值) 值. 见 get_options() 关于 pi, pj, pk 的含义. 返回检索到的值. 值通常以个为单位指定, 但可以使用“K”或“M”的后缀分别指定“千”(1024) 或“兆”($1024^2$).

int get_opt_val(int argc, char **argv, int *pi, int *pj, int *pk) {
 int n, c;

 if (++(*pi) >= argc) {
 usage();
 exit(1);
 }
 n = atoi(argv[*pi]);
 c = argv[*pi][strlen(argv[*pi])-1];
 switch (c) {
 case 'K': n = n * 1024; break;
 case 'M': n = n * 1024 * 1024; break;
 }
 *pj = *pk = 0;
 return n;
}

void help(void) {
 fputc('\n', stderr);
 usage();
 fprintf(stderr,
 "\n"
 "-b   batch mode (quiet, exit on first error)\n"
 "-g   report number of free nodes after each GC\n"
 "-i   init mode (do not load any image)\n"
 "-n # number of nodes to allocate (default: %dK)\n"
 "-L   print license and exit\n"
 "\n"
 "default image: %s\n\n",
 DEFAULT_NODES/1024, DEFAULT_IMAGE);
}

void print_license(void) {
 char **s;

 s = zen_license();
 while (*s) {
 printf("%s\n", *s);
 s++;
 }
 exit(0);
}

解析传递给解释器 shell 的命令行选项. 在没有选项的情况下设置默认值. 变量 i (当前选项), j (当前选项字符串的当前字符) 和 k (当前选项字符串的长度) 作为指针传递给 get_opt_val() 以提取选项的参数值.

void get_options(int argc, char **argv) {
 char *a;
 int i, j, k;
 int v;

 strncpy(Image, DEFAULT_IMAGE, strlen(DEFAULT_IMAGE));
 Image[MAX_PATH_LEN-1] = 0;
 Nodes = DEFAULT_NODES;
 GC_stats = 0;
 Batch = 0;
 v = 0;
 i = 1;
 while (i < argc) {
 a = argv[i];
 if (a != '-') break;
 k = strlen(a);
 for (j=1; j<k; j++) {
 switch (a[j]) {
 case 'b':
 Batch = 1;
 break;
 case 'n':
 Nodes = get_opt_val(argc, argv, &i, &j, &k);
 break;
 case 'g':
 GC_stats = 1;
 break;
 case 'i':
 Image = 0;
 break;
 case 'L':
 print_license();
 break;
 case '?':
 case 'h':
 help();
 exit(1);
 break;
 default:
 usage();
 exit(1);
 }
 }
 i = i+1;
 }
 if (i < argc) {
 strncpy(Image, a, strlen(a)+1);
 Image[MAX_PATH_LEN-1] = 0;
 }
 if (Nodes < MINIMUM_NODES) {
 fprintf(stderr, "zenlisp: minimal pool size is %d\n",
 MINIMUM_NODES);
 exit(1);
 }
}

SIGINT 处理程序.

void catch_int(int sig) {
 USE(sig);
 zen_stop();
 signal(SIGINT, catch_int);
}

repl() 函数实现了主要的解释器循环, 即所谓的 REPL (read-eval-print loop). 顾名思义, 它从输入流中读取一个表达式, 对其进行求值, 打印结果的范式 (如果有的话), 最后循环. 当 REPL 接收到一个 EOT 字符 (或者在批处理模式下报告错误后) 时, REPL 退出.

void repl(void) {
 int n;

 while(1) {
 Error_flag = 0;
 n = zen_read();
 if (n == EOT) return;
 if (Error_flag) {
 zen_print_error();
 if (Batch) exit(1);
 continue;
 }
 n = zen_eval(n);
 if (Error_flag) {
 zen_print_error();
 if (Batch) exit(1);
 }
 else {
 if (!Batch) pr("=> ");
 zen_print(n);
 nl();
 }
 }
}

void init(void) {
 if (zen_init(Nodes, GC_stats)) {
 fprintf(stderr, "zenlisp init failed (memory problem)\n");
 exit(1);
 }
}

准备起飞…

如果你想知道为什么选项被检查了两次: 第一次通过设置预初始化选项, 第二次设置后初始化选项.

int main(int argc, char **argv) {
 get_options(argc, argv);
 init();
 get_options(argc, argv);
 if (!Batch) {
 pr("zenlisp ");
 pr(RELEASE);
 pr(" by Nils M Holm");
 nl();
 }
 if (Image) {
 if (zen_load_image(Image)) {
 zen_print_error();
 if (Batch) exit(1);
 zen_fini();
 init();
 get_options(argc, argv);
 }
 }
 else if (!Batch) {
 pr("Warning: no image loaded");
 nl();
 }
 signal(SIGINT, catch_int);
 repl();
 zen_fini();
 return 0;
}

3.2. 13. lisp 部分

3.2.1. 13.1 基础库

这部分描述了 zenlisp 解释器默认映像中包含的 LISP 函数. 它们包含在文件 `base.l` 中. 这里定义的函数在本书的第一部分已经详细讨论过.

每个函数定义前面都有一个原型. 原型提供了关于函数的额外的、半形式化的信息, 但它们不是 zenlisp 语言的一部分. 有关函数原型的解释, 请参见第 222 页.

作为 zenlisp 语言一部分的函数名称在其定义中以粗体字符打印. 未以粗体字符打印的函数名称是其包内部的, 不应在用户级 zenlisp 代码中使用.

; zenlisp base functions
; By Nils M Holm, 2007, 2008
; Feel free to copy, share, and modify this code.
; See the file LICENSE for details.

(define base :t)

(null form) ----> :t | :f

(define (null x) (eq x ()))

(id form) ----> form

(define (id x) x)

(list form ...) ----> list

(define (list . x) x)

(not form) ----> :t | :f

(define (not a) (eq a :f))

(neq form1 form2) ----> :t | :f

(define (neq x y) (eq (eq x y) :f))

(caar pair) ----> form
...
(cddddr pair) ----> form

(define (caaaar x) (car (car (car (car x)))))
(define (caaadr x) (car (car (car (cdr x)))))
(define (caadar x) (car (car (cdr (car x)))))
(define (caaddr x) (car (car (cdr (cdr x)))))
(define (cadaar x) (car (cdr (car (car x)))))
(define (cadadr x) (car (cdr (car (cdr x)))))
(define (caddar x) (car (cdr (cdr (car x)))))
(define (cadddr x) (car (cdr (cdr (cdr x)))))
(define (cdaaar x) (cdr (car (car (car x)))))
(define (cdaadr x) (cdr (car (car (cdr x)))))
(define (cdadar x) (cdr (car (cdr (car x)))))
(define (cdaddr x) (cdr (car (cdr (cdr x)))))
(define (cddaar x) (cdr (cdr (car (car x)))))
(define (cddadr x) (cdr (cdr (car (cdr x)))))
(define (cdddar x) (cdr (cdr (cdr (car x)))))
(define (cddddr x) (cdr (cdr (cdr (cdr x)))))
(define (caaar x) (car (car (car x))))
(define (caadr x) (car (car (cdr x))))
(define (cadar x) (car (cdr (car x))))
(define (caddr x) (car (cdr (cdr x))))
(define (cdaar x) (cdr (car (car x))))
(define (cdadr x) (cdr (car (cdr x))))
(define (cddar x) (cdr (cdr (car x))))
(define (cdddr x) (cdr (cdr (cdr x))))
(define (caar x) (car (car x)))
(define (cadr x) (car (cdr x)))
(define (cdar x) (cdr (car x)))
(define (cddr x) (cdr (cdr x)))

(fold function form list) ----> form

(define (fold f x a)
 (letrec
   ((fold2
      (lambda (a res)
        (cond ((null a) res)
              (t (fold2 (cdr a)
                        (f res (car a))))))))
   (fold2 a x)))

(fold-r function form list) ----> form

(define (fold-r f x a)
 (letrec
   ((fold2
      (lambda (a)
        (cond ((null a) x)
              (t (f (car a)
                    (fold2 (cdr a))))))))
   (fold2 a)))

(reverse list) ----> list

(define (reverse a)
 (letrec
   ((reverse2
      (lambda (a b)
        (cond ((null a) b)
              (t (reverse2 (cdr a)
                           (cons (car a) b)))))))
   (reverse2 a ())))

(append list ...) ----> list
(append atom) ----> atom
(append list1 list2 ... atom) ----> dotted list

(define (append . a)
 (letrec
   ((append2
      (lambda (a b)
        (cond ((null a) b)
              (t (append2 (cdr a) (cons (car a) b)))))))
   (fold (lambda (a b) (append2 (reverse a) b))
         ()
         a)))

(equal form1 form2) ----> :t | :f

equal 的第一个子句在比较相同的结构 (如共享列表的尾部) 时立即返回真. 这是一个性能优化.

(define (equal a b)
 (cond ((eq a b) :t)
       ((or (atom a) (atom b))
        (eq a b))
       (t (and (equal (car a) (car b))
               (equal (cdr a) (cdr b))))))

(assoc form alist) ----> pair | :f

(define (assoc x a)
 (cond ((null a) :f)
       ((equal (caar a) x) (car a))
       (t (assoc x (cdr a)))))

(assq atom alist) ----> pair | :f

(define (assq x a)
 (cond ((null a) :f)
       ((eq (caar a) x) (car a))
       (t (assq x (cdr a)))))

(listp form) ----> :t | :f

(define (listp x)
 (or (null x)
     (and (not (atom x))
          (listp (cdr x)))))

(map function list1 list2 ...) ----> list

(define (map f . a)
 (letrec
   ((map-car
      (lambda (f a r)
        (cond ((null a) (reverse r))
              (t (map-car f (cdr a) (cons (f (car a)) r))))))
    (car-of
      (lambda (a)
        (map-car car a ())))
    (cdr-of
      (lambda (a)
        (map-car cdr a ())))
    (any-null
      (lambda (a)
        (apply or (map-car null a ()))))
    (map2
      (lambda (a b)
        (cond ((any-null a) (reverse b))
              (t (map2 (cdr-of a)
                       (cons (apply f (car-of a)) b)))))))
   (cond ((null a) (bottom '(too few arguments to map)))
         (t (map2 a ())))))

(member form list) ----> form | :f

(define (member x a)
 (cond ((null a) :f)
       ((equal (car a) x) a)
       (t (member x (cdr a)))))

(memq atom list) ----> form | :f

(define (memq x a)
 (cond ((null a) :f)
       ((eq (car a) x) a)
       (t (memq x (cdr a)))))

(require symbol) ----> :t | :f

(define (require x)
 (letrec
   ((require2
      (lambda (sym file)
        (cond ((defined sym) :f)
              (t (apply load (list file)))))))
   (let ((xx (explode x)))
     (cond ((eq (car xx) '~)
            (require2 (implode (cdr xx)) x))
           (t (require2 x x))))))

3.2.2. 13.2 迭代器包

iter 包为算术函数和谓词定义了迭代器. 这些函数在本书的第一部分 [pages 45 and 53] 已经详细讨论过.

迭代器包包含在文件 `iter.l` 中.

; zenlisp iterators
; By Nils M Holm, 2007, 2008
; Feel free to copy, share, and modify this code.
; See the file LICENSE for details.

(define iter :t)

(arithmetic-iterator function1 function2 number) ----> function

(define (arithmetic-iterator conv fn neutral)
 (lambda x
   (cond ((null x) neutral)
         (t (fold (lambda (a b)
                    (fn (conv a) (conv b)))
                  (car x)
                  (cdr x))))))

(predicate-iterator function1 function2) ----> function

(define (predicate-iterator conv fn)
 (let ((fail (cons 'fail ())))
   (let ((comp (lambda (a b)
                 (cond ((eq a fail) fail)
                       ((fn (conv a) (conv b)) b)
                       (t fail)))))
     (lambda (first . rest)
       (cond ((null rest) (bottom '(too few arguments)))
             (t (neq (fold comp first rest) fail)))))))

3.2.3. 13.3 自然数数学函数

nmath 包在符号 '0…'9 的基础上实现了自然数算术. 每个自然数是这些符号的列表. 这就是为什么数字可以以压缩形式书写的原因, 例如 '#31415 代替 '(3 1 4 1 5). 事实上, 压缩列表最初是为了提供一种更方便的数字表示法而发明的. 这也是为什么选择“数字”符号来引入压缩列表的原因.

nmath 包构成了 zenlisp 数值塔的基础, 如图 17 所示. 数值塔的每一层都建立在实现更原始类型的“较低”层之上.

Nmath 本身由三层组成, 实现了算术表、使用这些表实现单数字算术的函数, 以及最后的自然数数学函数本身.

每个数学包都可以单独加载, 但加载 imath 将包括 nmath, 加载 rmath 将加载完整的数值塔.

虽然更原始的数学包缺少更复杂的包提供的一些功能, 但它们通常是首选, 因为在执行相同任务时它们更有效率.

例如, 使用自然数算术计算 $2^{100}$ 比使用相应的有理数函数快得多. 另一方面, 自然数和整数版本不接受负指数. 因此

应谨慎选择数学包.

自然数数学包包含在文件 `nmath.l` 中.

; zenlisp natural math functions
; By Nils M Holm, 2007
; Feel free to copy, share, and modify this code.
; See the file LICENSE for details.

Nmath 需要 base, 但 require 在 base 中定义, 所以这里不能使用:

(cond ((defined 'base) :f)
      (t (load base)))

(define nmath :t)

首先将数字符号定义为常量, 这样你就可以写 0 而不是 '0.

(define 0 '0)
(define 1 '1)
(define 2 '2)
(define 3 '3)
(define 4 '4)
(define 5 '5)
(define 6 '6)
(define 7 '7)
(define 8 '8)
(define 9 '9)

(define *digits* '#0123456789)

(digitp form) ----> :t | :f

(define (digitp x) (and (memq x *digits*) :t))

succ 和 pred 函数计算一个数字的后继和前驱. 当发生溢出或下溢时, 它们都返回 :f. 这些函数在代码中不常用. Pred 只使用了几次, 而 succ 完全没有使用 (保留它是为了对称性). 两个函数都参与了早期版本 (ArrowLISP) 中更复杂的数值函数的实现, 但 zenlisp 使用表驱动的算术. 详见下文.

(succ symbol) ----> symbol | :f

(define (succ x)
 (cond ((eq x 0) 1)
       ((eq x 1) 2)
       ((eq x 2) 3)
       ((eq x 3) 4)
       ((eq x 4) 5)
       ((eq x 5) 6)
       ((eq x 6) 7)
       ((eq x 7) 8)
       ((eq x 8) 9)
       ((eq x 9) :f)
       (t (bottom '(not a digit:) x))))

(pred symbol) ----> symbol | :f

(define (pred x)
 (cond ((eq x 1) 0)
       ((eq x 2) 1)
       ((eq x 3) 2)
       ((eq x 4) 3)
       ((eq x 5) 4)
       ((eq x 6) 5)
       ((eq x 7) 6)
       ((eq x 8) 7)
       ((eq x 9) 8)
       ((eq x 0) :f)
       (t (bottom '(not a digit:) x))))

sum-of-digits 结构包含所有数字组合的和, 形式为

(sum . carry)

两个数字 a 和 b 相加的结果可以在该结构的 a 行 b 列中找到. 每行有十一列, 以支持单位进位值.

(define *sums-of-digits* '(
                           ((0.0) (1.0) (2.0) (3.0) (4.0) (5.0) (6.0) (7.0) (8.0) (9.0) (0.1))
                           ((1.0) (2.0) (3.0) (4.0) (5.0) (6.0) (7.0) (8.0) (9.0) (0.1) (1.1))
                           ((2.0) (3.0) (4.0) (5.0) (6.0) (7.0) (8.0) (9.0) (0.1) (1.1) (2.1))
                           ((3.0) (4.0) (5.0) (6.0) (7.0) (8.0) (9.0) (0.1) (1.1) (2.1) (3.1))
                           ((4.0) (5.0) (6.0) (7.0) (8.0) (9.0) (0.1) (1.1) (2.1) (3.1) (4.1))
                           ((5.0) (6.0) (7.0) (8.0) (9.0) (0.1) (1.1) (2.1) (3.1) (4.1) (5.1))
                           ((6.0) (7.0) (8.0) (9.0) (0.1) (1.1) (2.1) (3.1) (4.1) (5.1) (6.1))
                           ((7.0) (8.0) (9.0) (0.1) (1.1) (2.1) (3.1) (4.1) (5.1) (6.1) (7.1))
                           ((8.0) (9.0) (0.1) (1.1) (2.1) (3.1) (4.1) (5.1) (6.1) (7.1) (8.1))
                           ((9.0) (0.1) (1.1) (2.1) (3.1) (4.1) (5.1) (6.1) (7.1) (8.1) (9.1))
                           ))

diffs-of-digits 结构包含所有数字组合的差, 形式为

(difference . borrow)

该结构的工作方式与上面的 sums-of-digits 相同. 因为“减”运算不是可交换的, 所以在差运算中查找第一个操作数在行中, 第二个操作数在该行的列中是很重要的.

(define *diffs-of-digits* '(
                            ((0.0) (9.1) (8.1) (7.1) (6.1) (5.1) (4.1) (3.1) (2.1) (1.1) (0.1))
                            ((1.0) (0.0) (9.1) (8.1) (7.1) (6.1) (5.1) (4.1) (3.1) (2.1) (1.1))
                            ((2.0) (1.0) (0.0) (9.1) (8.1) (7.1) (6.1) (5.1) (4.1) (3.1) (2.1))
                            ((3.0) (2.0) (1.0) (0.0) (9.1) (8.1) (7.1) (6.1) (5.1) (4.1) (3.1))
                            ((4.0) (3.0) (2.0) (1.0) (0.0) (9.1) (8.1) (7.1) (6.1) (5.1) (4.1))
                            ((5.0) (4.0) (3.0) (2.0) (1.0) (0.0) (9.1) (8.1) (7.1) (6.1) (5.1))
                            ((6.0) (5.0) (4.0) (3.0) (2.0) (1.0) (0.0) (9.1) (8.1) (7.1) (6.1))
                            ((7.0) (6.0) (5.0) (4.0) (3.0) (2.0) (1.0) (0.0) (9.1) (8.1) (7.1))
                            ((8.0) (7.0) (6.0) (5.0) (4.0) (3.0) (2.0) (1.0) (0.0) (9.1) (8.1))
                            ((9.0) (8.0) (7.0) (6.0) (5.0) (4.0) (3.0) (2.0) (1.0) (0.0) (9.1))
                            ))

%nth-item 函数从列表 lst 中获取第 d 个项目. D 必须是一个数字, 而不是一个 zenlisp 数字. Nth-item 用于在上述和差表中查找值.

(%nth-item digit list) ----> form

(define (%nth-item d lst)
  (cond ((eq d 0) (car lst))
        (t (%nth-item (pred d) (cdr lst)))))

%D+ 将两个数字和一个进位标志 (由数字 0 和 1 表示) 相加, 并提供一个由它们的和和一个新的进位值组成的对. 它基本上实现了一个十进制单位数全加器.

(%d+ digit1 digit2 0|1) ----> '(sum . carry)

(define (%d+ a b carry)
  (let ((row (%nth-item b *sums-of-digits*)))
    (cond ((eq carry 1) (%nth-item a (cdr row)))
          (t (%nth-item a row)))))

%D- 从一个数字 a 中减去一个数字 b 和一个借位标志. 借位标志由数字 0 和 1 表示. %D- 并提供一个由差和一个新的借位标志组成的对.

(%d- digit1 digit2 0|1) ----> '(difference . borrow)

(define (%d- a b carry)
  (let ((row (%nth-item a *diffs-of-digits*)))
    (cond ((eq carry 1) (%nth-item b (cdr row)))
          (t (%nth-item b row)))))

%D< 是一个谓词, 如果数字 a 的值小于数字 b, 则返回 :t.

(define (%d< a b)
  (letrec
    ((dless
       (lambda (set)
         (cond ((null set)
                (bottom '(not digits:) a b))
               ((eq a (car set))
                (not (eq b (car set))))
               ((eq b (car set)) :f)
               (t (dless (cdr set)))))))
    (dless *digits*)))

Natural-p 检查其参数是否是一个自然数 (一个非空的数字列表).

(natural-p form) ----> :t | :f

(define (natural-p x)
  (letrec
    ((lod-p
       (lambda (x)
         (cond ((null x) :t)
               ((atom x) :f)
               (t (and (digitp (car x))
                       (lod-p (cdr x))))))))
    (and (not (atom x))
         (lod-p x))))

N-natural 将一个数字转换为自然数. 因为此时只有自然数, 所以这是一个恒等操作.

(n-natural natural) ----> natural

(define n-natural id)

通过移除前导零来规范化一个自然数.

(n-normalize natural) ----> natural

(define (n-normalize x)
  (cond ((null (cdr x)) x)
        ((eq (car x) 0)
         (n-normalize (cdr x)))
        (t x)))

检查两个自然数是否严格按升序排列. N< 使用一个空的 let 来封闭 %d<. 这种构造在包中用于保护内部符号免受意外的重新定义.

(n< natural1 natural2) ----> :t | :f

(define n<
  (let ()
    (lambda (a b)
      (letrec
        ((d> (lambda (a b)
               (%d< b a)))
         (lt (lambda (a b r)
               (cond ((and (null a) (null b)) r)
                     ((null a) :t)
                     ((null b) :f)
                     (t (lt (cdr a)
                            (cdr b)
                            (cond ((%d< (car a) (car b)) :t)
                                  ((d> (car a) (car b)) :f)
                                  (t r))))))))
        (lt (reverse a) (reverse b) :f)))))

其他排序谓词可以很容易地从 n< 派生出来:

(n> natural1 natural2) ----> :t | :f
(n<= natural1 natural2) ----> :t | :f
(n>= natural1 natural2) ----> :t | :f

(define (n> a b) (n< b a))
(define (n<= a b) (eq (n> a b) :f))
(define (n>= a b) (eq (n< a b) :f))

检查两个自然数是否相等.

(n= natural1 natural2) ----> :t | :f

(define (n= a b)
  (equal (n-normalize a)
         (n-normalize b)))

将两个自然数相加. 这里使用的算法基本上是大多数人在纸上相加两个数字时使用的算法. 它从最低有效位开始, 并通过整个数字行传播一个进位标志. 当一个数字比另一个数字少几位时, 不存在的数字被 0 替换.

(n+ natural1 natural2) ----> natural

(define n+
  (let ()
    (lambda (a b)
      (letrec
        ((add
           (lambda (a b c r)
             (cond ((null a)
                    (cond
                      ((null b)
                       (cond ((eq c 0) r) ; no carry
                             (t (cons 1 r))))
                      (t (let ((sum (%d+ 0 (car b) c)))
                           (add ()
                                (cdr b)
                                (cdr sum)
                                (cons (car sum) r))))))
                   ((null b)
                    (let ((sum (%d+ (car a) 0 c)))
                      (add (cdr a)
                           ()
                           (cdr sum)
                           (cons (car sum) r))))
                   (t (let ((sum (%d+ (car a) (car b) c)))
                        (add (cdr a)
                             (cdr b)
                             (cdr sum)
                             (cons (car sum) r))))))))
        (add (reverse a) (reverse b) 0 ())))))

从两个自然数中减去. 类似于上面的 n+.

(n- natural1 natural2) ----> natural

(define n-
  (let ()
    (lambda (a b)
      (letrec
        ((diff
           (lambda (a b c r)
             (cond ((null a)
                    (cond
                      ((null b)
                       (cond ((eq c 0) r)
                             (t (bottom '(negative difference)))))
                      (t (bottom '(negative difference)))))
                   ((null b)
                    (cond ((eq c 0)
                           (append (reverse a) r))
                          (t (diff a '(1) 0 r))))
                   (t (let ((delta (%d- (car a) (car b) c)))
                        (diff (cdr a)
                              (cdr b)
                              (cdr delta)
                              (cons (car delta) r))))))))
        (n-normalize (diff (reverse a) (reverse b) 0 ()))))))

测试一个自然数是零还是一. 这些函数分别等价于 (= x 0) 和 (= x 1), 但效率更高.

(n-zero natural) ----> :t | :f
(n-one natural) ----> :t | :f

(define (n-zero x)
  (and (eq (car x) 0)
       (null (cdr x))))
(define (n-one x)
  (and (eq (car x) 1)
       (null (cdr x))))

将两个自然数相乘. 该算法使用十进制左移操作来乘以 10.

(n* natural1 natural2) ----> natural

(define (n* a b)
  (letrec
    ((*10
       (lambda (x)
         (append x '#0)))
     (add-n-times
       (lambda (a b r)
         (cond ((n-zero (list b)) r)
               (t (add-n-times a (pred b) (n+ a r))))))
     (times
       (lambda (a b r)
         (cond ((null b) r)
               (t (times (*10 a)
                         (cdr b)
                         (add-n-times a (car b) r)))))))
    (cond ((n-zero a) '#0)
          (t (times a (reverse b) '#0)))))

将两个自然数相除, 得到一个形式为 (quotient remainder) 的列表. 除法算法的工作方式如下:

将除数向左移动, 直到它与被除数具有相同的位数;
设 n 为除数被移动的位数;
设结果 R 为 '#0;
做 n 次:
- 测试除数能整除被除数多少次; 将这个数命名为 q;
- 从被除数中减去 q 次除数;
- 将 q 附加到 R; ²¹
- 将除数向右移动一位.
规范化结果 R.

4. 附录 A

4.1. A.1 尾调用规则

尾递归程序是一个完全使用尾调用进行递归的程序.

尾调用是在尾部位置的函数调用.

以下是 zenlisp 中尾部位置的详尽列表:

(lambda (...) (function ...))

函数体中最外层的函数调用.

(let (...) body)

let 的主体.

(letrec (...) body)

letrec 的主体.

(apply function ...)

apply 的应用.

(and ... expression)

and 的最后一个参数.

(or ... expression)

or 的最后一个参数.

(cond ... (predicate body) ...)

cond 的每个主体.

注意尾调用规则可以组合. 在以下示例中, f 的应用处于尾部位置:

(lambda ()
  (let ()
    (cond (t (or :f :f (f))))))

4.2. A.2 zenlisp 函数

本摘要中使用以下符号:

Symbol	Meaning
alist	an association list
expr	any type of expression
form	any type of form (unevaluated)
fun	a function or closure
name	a symbol (unevaluated)
pair	a pair
symbol	a symbol
a	b	either a or b
a…	zero, one, or multiple instances of a

4.2.1. A.2.1 定义

(define name expr)

用值 expr 定义常量 name.

(define (name1 name2 ...) expr)

定义函数 name1, 带有可选变量 name2… 和主体 expr.

(defined symbol)

测试符号是否已定义.

(lambda (name ...) expr) | (lambda name expr)

创建带有变量 name… 或 name 和主体 expr 的闭包.

(let ((name1 expr1) ...) expr)

创建一个带有绑定 $name_i=expr_i$… 的环境, 并在该环境中求值 expr.

(letrec ((name1 expr1) ...) expr)

创建一个带有递归绑定 $name_i=expr_i$… 的环境, 并在该环境中求值 expr.

(quote form)

创建一个数据.

(recursive-bind alist)

修复环境中的递归绑定.

4.2.2. A.2.2 控制

(and expr ...)

归约表达式. 返回第一个给出 :f 的表达式或最后一个.

(apply fun expr ... list)

将 fun 应用于可选的表达式和 list 的成员.

(bottom expr ...)

归约为一个未定义的值.

(cond (exprp expr) ...)

归约为第一个其关联的 exprp 求值为真的 expr.

(eval expr)

将 expr 归约为其范式.

(or expr ...)

归约表达式. 返回第一个求值为真的表达式或最后一个.

4.2.3. A.2.3 列表

(append list ...)

附加列表.

(assoc expr alist)

在关联列表 alist 中查找键=expr 的关联; 否则返回 :f.

(assq symbol alist)

在关联列表 alist 中查找键=symbol 的关联; 否则返回 :f.

(caar pair) ... (cddddr pair)

提取嵌套对的部分. Caar = car of car, cadr = car of cdr, 等.

(car pair)

提取对的 car 部分.

(cdr pair)

提取对的 cdr 部分.

(cons expr1 expr2)

构造新的对 $'(expr_1 . expr_2)$.

(equal expr1 expr2)

测试 $expr_1$ 是否等于 (看起来与) $expr_2$ 相同.

(explode symbol)

将一个符号分解为单字符符号的列表.

(fold fun expr list)

在列表上用基值 expr 折叠 fun. 左结合版本.

(fold-r fun expr list)

在列表上用基值 expr 折叠 fun. 右结合版本.

(implode list)

从单字符符号的列表中组合一个符号.

(list expr ...)

用给定的成员创建一个列表.

(listp expr)

测试 expr 是否是一个正确的 (非点分) 列表.

(map fun list1 list2 ...)

在给定的列表上映射函数 fun.

(member expr list)

找到 list 中以 expr 开头的第一个子列表, 否则返回 :f.

(memq symbol list)

找到 list 中以 symbol 开头的第一个子列表, 否则返回 :f.

(null expr)

测试 expr 是否是 ().

(reverse list)

返回 list 的一个反向副本.

4.2.4. A.2.4 杂项

(atom expr)

测试 expr 是否是原子的 (一个符号或 ()).

(eq expr1 expr2)

测试 $expr_1$ 和 $expr_2$ 是否相同.

(id expr)

恒等函数 (返回 expr).

(neq expr1 expr2)

测试 $expr_1$ 和 $expr_2$ 是否不相同.

(not expr)

测试 expr 是否与 :f 相同 (逻辑“非”).

4.2.5. A.2.5 包

(require symbol)

如果给定的包尚未在内存中, 则加载它.

4.2.6. A.2.6 元函数

**

(好的, 这不是一个真正的函数.) 这个变量总是绑定到最新的顶层结果, 即解释器最近打印的范式.

(closure-form args | body | env)

控制打印多少闭包信息.

(dump-image name)

将工作区映像转储到文件 name. 通过将 name 传递给 zenlisp 来重新加载映像.

(gc)

运行垃圾回收并返回统计信息.

(load name)

从文件 name 加载定义.

(quit)

结束一个 zenlisp 会话.

(stats expr)

将 expr 归约为范式并返回一些统计信息.

(symbols)

返回符号表中所有符号的列表.

(trace name) | (trace)

跟踪具有给定名称的函数. (Trace) 关闭跟踪.

(verify-arrows :t | :f)

打开或关闭 => 运算符的验证.

4.3. A.3 数学函数

本摘要中使用的符号:

Symbol	Meaning
x	any number
r	rational number
i	integer number
n	natural number
[x]	x is optional
a	b	either a or b
a…	zero, one, or multiple instances of a

Function	Returns…
(* x …) => x	product
epsilon => n	$log_{10}$ of precision of sqrt
(+ x …) => x	sum
(- x1 x2 x3 …) => x	difference
(- x) => x	negative number
(/ x1 x2 x3 …) => x	ratio
(< x1 x2 x3 …) => :t	:f	:t for strict ascending order
(<= x1 x2 x3 …) => :t	:f	:t for strict non-descending order
(= x1 x2 x3 …) => :t	:f	:t for equivalence
(> x1 x2 x3 …) => :t	:f	:t for strict descending order
(>= x1 x2 x3 …) => :t	:f	:t for strict non-ascending order
(abs x) => x	absolute value
(denominator r) => i	denominator
(divide i1 i2) => '(i3 i4)	quotient i3 and remainder i4
(even i) => :t	:f	:t, if i is even
(expt x i) => x	x to the power of i
(gcd i1 i2 …) => n	greatest common divisor
(integer x) => i	an integer with the value x
(integer-p x) => :t	:f	:t, if x is integer
(lcm i1 i2 …) => n	least common multiple
(length list) => n	length of a list
(max x1 x2 …) => x	maximum value
(min x1 x2 …) => x	minimum value
(modulo i1 i2) => i3	modulus
(natural x) => n	a natural with the value x
(natural-p x) => :t	:f	:t, if x is natural
(negate i	r) => i	r	negative value
(negative x) => :t	:f	:t, if x is negative
(number-p expr) => :t	:f	:t, if expr represents a number
(numerator r) => i	numerator
(odd i) => :t	:f	:t, if i is not even
(one x) => :t	:f	:t, if x equals one
(quotient i1 i2) => i	quotient
(rational x) => r	a rational with the value x
(rational-p x) => :t	:f	:t, if x is rational
(remainder i1 i2) => i	division remainder
(sqrt n) => x	square root, see also epsilon
(zero x) => :t	:f	:t, if x equals zero

4.4. A.4 使用 zenlisp

元函数会改变 zenlisp 系统的状态.

load 元函数读取一个文本文件, 并将该文件中包含的所有表达式归约为它们的范式.

给定一个名为 `palindrome.l` 的文件, 包含以下几行

(define (palindrome x)
  (append x (reverse x)))

函数应用

(load palindrome)

将加载上述定义.

Load 会自动将 `.l` 后缀附加到文件名.

再次加载相同的文件将更新所有定义.

当文件名以波浪号开头时, load 会从一个预定义的位置加载一个 zenlisp 包. 例如

(load ~nmath)

会将自然数数学函数加载到 zenlisp 系统中. 系统包的实际位置由 $ZENSRC 环境变量指定.

虽然 load 通常用于交互式地加载包, 但 require 用于使一个程序依赖于一个包 [page 62].

一个以函数应用开头的程序

(require '~rmath)

依赖于 rmath 包.

因为 require 是一个 lambda 函数 (而不是一个内部伪函数), 它的参数必须被引用. 与 load 不同, require 永远不会加载一个包两次:

(require '~rmath) => :t
(require '~rmath) => :f

因此它可以用来加载相互依赖的包.

dump-image 元函数将完整的 zenlisp 工作区转储到一个文件:

(load ~rmath)
(load ~amk)
(dump-image my-workspace)

这个会话创建了一个名为 my-workspace 的新映像文件, 其中包含了 rmath 和 amk 包.

要加载一个映像, 将映像文件名传递给 zenlisp (% 是 Unix shell 的提示符):

% zl my-workspace

trace 元函数使解释器跟踪特定函数的应用:

(define (d x) (or (atom x) (d (cdr x))))
(d '#xyz) => :t
(trace d) => :t
(d '#xyz)
+ (d #xyz)
+ (d #yz)
+ (d #z)
+ (d ())
=> :t

不带参数地应用 trace 会关闭跟踪:

(trace) => :t

stats 元函数测量表达式归约期间使用的资源:

(stats (append '#abc '#def))
=> '(#abcdef #240 #1,213 #0)

它的范式是一个包含以下信息的列表:

'(normal-form steps nodes gcs)

其中

normal-form 是要求值的表达式的范式;
steps 是执行的归约步骤数;
nodes 是归约期间分配的节点数;
gcs 是归约期间执行的垃圾回收次数.

verify-arrows 函数打开或关闭验证模式. 传递 :t 给它启用验证, :f 禁用它:

(verify-arrows t) => :t

在验证模式下, => 运算符通过确保每个 => 左侧的范式与其右侧匹配来进行验证:

(cons 'heads 'tails) => '(heads . tails) ; OK
(cons 'heads 'tails) => 'foo             ; FAIL

只要一个表达式归约为预期的范式, 就不会有任何特殊情况发生. 然而, 当形式不匹配时, zenlisp 会报告一个错误:

(cons 'heads 'tails) => 'foo
=> '(heads . tails)
 * 2: REPL: Verification failed; expected: 'foo

在非验证模式下, => 会引入一个到行尾的注释 (就像 ;), 从而方便表达式的剪切和粘贴.

quit 元函数结束一个 zenlisp 会话:

(quit)

出于显而易见的原因, (quit) 没有范式.

4.4.1. A.4.1 开发周期

虽然你可以在读-求值-打印循环 (REPL) 中输入整个程序, 但这样做可能会有点不方便, 因为 zenlisp REPL 缺乏除最基本的编辑功能外的所有功能.

所以建议你使用你选择的文本编辑器来输入或修改 zenlisp 程序. 例如, 你可能已经输入了以下代码并将其保存到文件 hanoi.l 中: ²²

4.5. A.5 有经验的 Scheme 程序员的 zenlisp

Zenlisp 很像 Revised5 Report on the Algorithmic Language Scheme (R5RS) 中定义的 Scheme 编程语言的一个小子集, 但有一些或多或少的微妙差异. 这是最重要的差异的摘要.

唯一的类型是 pair 和 atom, atom 是符号或 ().

规范的真值是 :t, 假值是 :f.

主体是单个表达式, 没有 begin.

Cond 必须有一个默认子句.

() 不需要被引用 (但这样做也无妨).

谓词没有尾随的“?”, 所以你写 (zero x) 而不是 (zero? x).

单字符符号的列表可以被“压缩”: '(x y z) = '#xyz

数字是列表: (+ '#12 '#34) => '#46

特殊形式处理程序是头等对象: lambda => {internal lambda}

Apply 对特殊形式工作得很好: (apply or '(:f :f :f 'foo)) => 'foo

Letrec 是用 let 和 recursive-bind 定义的, 而不是 let 和 set!.

闭包有头等的环境: (cadddr (lambda () x)) => '((x . {void}))

所有数据都是不可变的, 没有 set!.

4.6. A.6 一些问题的答案

4.6.1. Q1, 第 63 页

赞成: (headp () x) 对任何 x 都应该产生 :t, 因为所有列表都有零个前导元素是共同的.

反对: (headp () x) 对任何 x 都应该产生 :f, 因为 (cons () x) /== x.

混淆的产生是因为术语“列表的头部”被用来命名两个不同的东西: 一个 pair 的 car 部分和列表的前导元素. 当 headp 被命名为类似 common-leading-members-p 的东西时, 事情会变得更清楚. (Common-leading-members () x) 应该总是产生 :t.

奖励问题仍然存在: 为 headp 找到一个比 common-leading-members-p 更短的更好的名字.

4.6.2. Q2, 第 64 页

这个版本的 count 会令人困惑, 因为它会计算正确列表的尾随 () , 所以

(count '()) => '#1 ; fine

但是

(count '(a b c)) => '#4 ; oops
(count '(a (b) c)) => '#5 ; oops

4.6.3. Q3, 第 66 页

是的, flatten 可以完全使用尾调用转换为一个函数. 任何函数都可以以这种方式转换. 然而, 在 flatten 的情况下, 这种转换不会提高效率, 因为该函数构造了一个树结构, 所以它必须使用某种结构递归.

4.6.4. Q4, 第 68 页

在这种特殊情况下, 使用 append 并不关键, 因为 append 的第一个参数不会增长:

(trace append) => :t
(fold-right (lambda (x y z) (list 'op x y z))
 '0
 '(a b c)
 '(d e f))
+ (append #cf #0)
+ (append #be ((op c f 0)))
+ (append #ad ((op b e (op c f 0))))
=> '(op a d (op b e (op c f 0)))

4.6.5. Q5, 第 68 页

替换不是 beta 归约的合适替代品, 因为它会替换自由变量和绑定变量:

(substitute '(list (lambda (x) x)) '((x . #17)))
=> '(list #17 (lambda (#17) #17))

4.6.6. Q6, 第 70 页

插入排序在排序一个已经排序的 n 元素列表时需要大约 $n^2/2$ 步:

(load ~nmath)
(load ~isort)
(trace sort)
(isort < '(#1 #2 #3 #4 #5))
+ (sort (#1 #2 #3 #4 #5) ())
+ (sort (#2 #3 #4 #5) (#1)) ; element inserted after 1 step
+ (sort (#3 #4 #5) (#1 #2)) ; element inserted after 2 steps
+ (sort (#4 #5) (#1 #2 #3)) ; element inserted after 3 steps
+ (sort (#5) (#1 #2 #3 #4)) ; element inserted after 4 steps
+ (sort () (#1 #2 #3 #4 #5)) ; element inserted after 5 steps
=> '(#1 #2 #3 #4 #5)      ; total = 15 steps

它需要 n 步来排序一个反向排序的列表:

(isort < '(#5 #4 #3 #2 #1))
+ (sort (#5 #4 #3 #2 #1) ())
+ (sort (#4 #3 #2 #1) (#5)) ; element inserted after 1 step
+ (sort (#3 #2 #1) (#4 #5)) ; element inserted after 1 step
+ (sort (#2 #1) (#3 #4 #5)) ; element inserted after 1 step
+ (sort (#1) (#2 #3 #4 #5)) ; element inserted after 1 step
+ (sort () (#1 #2 #3 #4 #5)) ; element inserted after 1 step
=> '(#1 #2 #3 #4 #5)      ; total = 5 steps

isort 所需的平均步数是这些极端值的平均值.

因为 isort 的运行时间在这些极端值所限定的范围内不易预测, 所以它不是一个可行的排序算法.

4.6.7. Q7, 第 73 页

严格来说, 大多数排序函数使用非严格谓词来对集合进行排序, 即使严格谓词在现实世界中更受欢迎. 例如,

(S < '(#1 #1)) => bottom

对于任何排序算法 S 都应该成立, 因为在包含相等成员的集合上不能施加严格的顺序.

所以如果你想要一个数学上正确的表示法, 非严格谓词是你的选择. 如果你想随大流, 严格谓词就是你想要的.

4.6.8. Q8, 第 73 页

这个版本的 insert 在使用非严格谓词时是稳定的:

(define (insert p x a)
(letrec
  ((ins
     (lambda (a r)
       (cond ((null a)
              (reverse (cons x r)))
             ((not (p x (car a)))
              (ins (cdr a) (cons (car a) r)))
             (t (append (reverse (cons x r)) a))))))
  (ins a ())))

任何排序算法都可以从严格谓词下的稳定性转换到非严格谓词下的稳定性, 反之亦然, 使用以下方案.

在每个排序算法中, 都有一个比较元素的点:

(cond ((p x y) sort-them)
      (t already-sorted))

这部分代码通过否定谓词和交换分支来修改:

(cond ((not (p x y)) already-sorted)
      (t sort-them))

4.6.9. Q9, 第 77 页

因为 unsort 从源列表的相当随机的位置挑选成员, 所以它具有与 isort 相同的平均复杂度, 后者在相当随机的位置插入成员.

4.6.10. Q10, 第 80 页

省略该子句将使 for-all 变成一个谓词.

4.6.11. Q11, 第 83 页

combine 的复杂度完全取决于其第二个参数: 源集合的大小. 迭代第一个参数会产生一条退化的曲线:

(map length
     (map (lambda (x) (combine x '#abcde))
          '(#1 #2 #3 #4 #5 #6 #7 #8 #9 #10)))
=> '(#5 #10 #10 #5 #1 #0 #0 #0 #0 #0)

tails-of 函数用于迭代不同大小的集合, 以估计 combine 的复杂度:

(map length
     (map (lambda (x) (combine '#5 x))
          (reverse (tails-of '#0123456789abcdef))))
=> '(#0 #0 #0 #0 #1 #6 #21 #56 #126 #252 #462 #792 #1287 #2002 #3003)

因为点之间的距离在曲线的 y 轴上不断增加, 所以复杂度比线性的差. 它可能甚至比 $O(n^2)$ 差, 因为 $16^2 = 256$, 而上面的函数对于集合大小为 16 的情况产生 3003. 复杂度可能比 $O(2^n)$ 好, 不过, 因为 $3003<2^{16}$, 值的平均增长小于前一个值的两倍.

要弄清楚 combine 是表现出具有大指数的多项式行为还是具有小指数的指数行为, 需要更精确的分析.

因为 combine 使用结构递归 (通过 map 的递归是结构递归的明显标志), 指数复杂度似乎很有可能.

类似的方法可以用来估计 combine* 的复杂度.

4.6.12. Q12, 第 85 页

这里是修改后的 permutations 函数, 附加的子句以粗体字符呈现:

(define (permutations set)
(cond
  ((null set) ())
  ((null (cdr set)) (list set))
  ((null (cddr set)) (rotations set))
  (t (apply append
       (map (lambda (rotn)
              (map (lambda (x)
                     (cons (car rotn) x))
                   (permutations (cdr rotn))))
            (rotations set))))))

是的, 这个修改是有意义的, 因为它将 permutations 的平均运行时间减少到原始版本的大约 67%.

无论这个优化多么巧妙, permutations 的复杂度保持不变, 因为对于一个 n 元素的集合, 仍然需要创建 n! 个排列:

(map length
     (map permutations
          (reverse (tails-of '#abcdefg))))
=> '(#1 #2 #6 #24 #120 #720 #5040)

4.6.13. Q13, 第 87 页

在 zenlisp 中计算 n! 的一个微不足道但有效的方法是:

(apply * (iota '#1 n))

它使用了第 86 页的 iota 函数. 你能解释为什么它甚至比递归乘积方法更有效率, 至少在 zenlisp 中是这样吗？

4.6.14. Q14, 第 90 页

确实, 为什么不呢:

(filter (lambda (x)
          (or (null (cdr x))
              (apply >= x)))
        (part '#4))
=> '((#1 #1 #1 #1) (#2 #1 #1) (#2 #2) (#3 #1) (#4))

4.6.15. Q15, 第 93 页

\[ 3^{(6)}3 = 3^{(5)}3^{(5)}3 \] \[ = 3^{(5)}3^{(4)}3^{(4)}3 \] \[ = 3^{(5)}3^{(4)}3^{3^3} \] \[ = 3^{(5)}3^{(4)}3^{27} \] \[ = 3^{(5)}3^{(4)}7625597484987 \] 上面等式最后一行的右半部分又是一个高度为 7,625,597,484,987 的幂塔 (如第 92 页所示). 但这一次, 那个巨大的数字仅仅描述了要应用于因子 3 的 hyper-5 运算的次数: \[ \left. \begin{matrix} 3^{(5)} \dots \end{matrix} \right\} 3^{(5)}3 \] \[ \left. \begin{matrix} \vdots \end{matrix} \right\} \] \[ \text{+---------- } 3^{(4)}7625597484987 \text{ times ----------+} \] 数字 $3^{(6)}3$ 确实很难描述, 即使是用幂-幂塔来描述.

4.6.16. Q16, 第 95 页

这是一个产生列表尾部的生成器:

((generator '#abcdef cdr)) => '(#abcd . {closure ()})
 (next **) => '(#bcd . {closure ()})
 (next **) => '(#cd . {closure ()})
 (next **) => '(#d . {closure ()})
 (next **) => bottom

当到达列表的末尾时, 生成器产生 bottom, 因为 cdr 不能取 () 的 cdr 部分. 有关更优雅的解决方案, 请参见下一节中介绍的“流”的概念.

4.6.17. Q17, 第 99 页

使用 fold-r, append-streams* 函数很容易实现:

(define (append-streams* . a)
(fold-r append-streams :f a))

将该函数应用于零个参数会产生“流结束”指示符 :f, 就像 (append) 产生“列表结束”指示符 () 一样.

4.6.18. Q18, 第 99 页

所有非递归的流函数 (加上 stream 本身) 都可以安全地应用于无限流. 这些函数是

stream map-stream filter-stream append-streams

当然, 将一个有限流附加到一个无限流会使有限流无法访问.

如文中所述, stream->list 是不安全的. stream-member 函数只有在保证流中存在具有所需属性的成员时才是安全的. 以下 stream-member 的应用会归约为 bottom:

(stream-member even
                 (stream '#1 id all (lambda (x) (+ '#2 x)) none :f)
                 :f)

4.6.19. Q19, 第 105 页

记录的签名的签名只有 symbol 类型的成员:

(record-signature (record '(food apple) '(weight #550) '(vegetarian :t)))
=> '((%record) (food symbol) (weight number) (vegetarian boolean))
(record-signature **)
=> '((%record) (food symbol) (weight symbol) (vegetarian symbol))

因为 symbol 是一个 symbol, 这个结果是 record-signature 函数的一个不动点: 将它传递给该函数将一遍又一遍地产生相同的结果.

4.6.20. Q20, 第 117 页

树结构由程序的调用树形成. 树的内部节点是解析器的函数.

4.6.21. Q21, 第 117 页

这是一个语法, 它给一元负号比幂运算符更低的优先级, 以至于 $-x^2 = -(x^2)$. 与第 110 页的语法的差异以粗体字符呈现.

<sum> := <term>
       | <term> '+' <sum>
       | <term> '-' <sum>

<term> := <negation>
        | <negation> '*' <term>
        | <negation> <term>
        | <negation> '/' <term>

<negation> := <power>
            | '-' <power>

<power> := <factor>
         | <factor> '^' <power>

<factor> := symbol
          | number
          ; removed the '-' <factor> rule
          | '[' <sum> ']'

4.6.22. Q22, 第 121 页

这是 prefix->infix 的 infix 子函数的一个版本, 它在所有二元运算符周围放置括号. 修改后的 prefix->infix 函数不使用 paren 和 add-parens 子函数.

与原始版本的差异以粗体字符打印:

(infix
  (lambda (x)
    (cond
      ((numeric-p x)
       (cadr x))
      ((symbol-p x)
       (list x))
      ((and (eq (car x) '-)
            (not (atom (cdr x)))
            (null (cddr x)))
       (append '#- (infix (cadr x))))
      ((and (eq (car x) '[])
            (not (atom (cdr x)))
            (null (cddr x)))
       (append '#[ (infix (cadr x)) '#]))
      ((and (not (atom x))
            (not (atom (cdr x)))
            (not (atom (cddr x)))
            (null (cdddr x))
            (function-p (car x)))
       (append '#[
               (infix (cadr x))
               (list (cdr (assq (car x) ops)))
               (infix (caddr x))
               '#]))
      (t (bottom (list 'syntax 'error: x))))))

显式地为所有操作添加括号在将一种语言的源代码翻译成另一种具有不同优先级规则的语言的源代码时很有用.

4.6.23. Q23, 第 121 页

RPN (逆波兰表示法, 后缀表示法) 不需要括号, 因为优先级由运算符和操作数的顺序表示:

Infix	RPN	zenlisp
((a + b) * c) - d	a b + c * d -	(- (* (+ a b) c) d)
(a + (b * c)) - d	a b c * + d -	(- (+ a (* b c)) d)
a + ((b * c) - d)	a b c * d - +	(+ a (- (* b c) d))
a + (b * (c - d))	a b c d - * +	(+ a (* b (- c d)))
(a + b) * (c - d)	a b + c d - *	(* (+ a b) (- c d))

注意, 只要所有运算符都接受两个参数, 前缀表示法也是无歧义的. 然而, 因为 zenlisp 函数可能是可变参数的, 所以需要显式的操作数分组.

4.6.24. Q24, 第 129 页

类 '#[-x] 和 '#[x-] 字面匹配字符“x”和“-”, 因为 x- 和 -x 都不是一个完整的范围.

类 '#[] 不匹配任何字符, 所以它是一个永远不匹配的类. '#[^] 匹配除空之外的任何字符, 所以它是 '#_ 的同义词. 然而, 大多数现实世界的正则表达式实现可能会以不同的方式处理这个问题.

4.6.25. Q25, 第 129 页

移除一次 reverse 的应用就足以将贪婪匹配器变成一个惰性匹配器:

(define (match-star cre s m)
(letrec
  ((try-choices
     (lambda (c*)
       (cond ((null c*) :f)
             (t (let ((r (match-cre (cdr cre) (caar c*) (cadar c*))))
                  (cond (r (append (reverse m) r))
                        (t (try-choices (cdr c*))))))))))
  (try-choices (make-choices cre s ()))))

Make-choices 返回的选项的顺序是最短的匹配在最前面, 所以 reverse 在原始实现中用于给予最长匹配优先权. 通过省略这个 reverse, 贪婪匹配器变成了一个惰性匹配器.

4.6.26. Q26, 第 138 页

特殊形式的求值不能委托给外部解释器, 因为一些特殊形式处理程序在内部调用 eval. 当这种情况发生时, 外部解释器的环境将被用来查找存储在内部解释器环境中的符号.

4.6.27. Q27, 第 138 页

因为 '%special 是一个普通的符号, 所以运算符的内部表示可以在程序中使用:

(zeval '('(%special . quote) foo) ()) => 'foo

这只是一个小问题, 但你可以通过使用一个唯一的实例 [page 55] (如 (list '%special)) 来代替符号 '%special 来标记特殊运算符来修复它, 例如:

(let ((%special (list '%special)))
  (letrec
    ((initial-env
       (list ...
             (cons 'and (cons %special and))
             (cons 'apply (cons %special apply))
             ...)))
    ...))

'%void 的一个不希望的效果是它不能用作变量的值, 因为这样做会使变量未绑定:

(zeval 'x '((x . %void))) => bottom

这个效果的补救方法与 '%special 相同.

4.7. A.7 图表列表

Figure	Title	Page
1	divide and conquer approach	71
2	run times of sorting algorithms	75
3	complexity of sorting algorithms	76
4	classes of complexity	77
5	syntax tree of x+y*z	110
6	right-associative syntax tree of x-y-z	112
7	meta-circular interpretation	129
8	the towers of hanoi	162
9	node pool structure	198
10	garbage collection, state 1	208
11	garbage collection, state 2	208
12	garbage collection, state 3	209
13	garbage collection, finished	209
14	symbols, atoms, and atomic nodes	214
15	primitive function structure	216
16	shared list	230
17	numeric tower	275

4.8. A.8 示例程序列表

Program	Page
combine	81
combine*	81
compose	42
contains	32
count	64
create-conser	37
depth	43
exists	79
ext-sub	60
factorial	86
factors	88
filter	42
flatten	65
fold-left	67
fold-right	67
for-all	80
generator	94
headp	63
hyper	92
insert	69
intersection	24
intersection*	25
intersection-list	24
iota	86
isort	70
lambda-rename	59
let->lambda	57
list->set	78
make-partitions	90
map-car	44
map-car-i	61
mergesort	72
ngcd	48
non-empty-list	26
nth	64
palindrome	12
part	89
partition	66
prefix->infix	117
re-compile	122
re-match	122
remove	43
replace	30
rotate	84
stream	95
subst-vars	61
substitute	68
tailp	63
transpose	93
union	78
unlet	58
unsort	73
zeval	130

4.9. A.9 代码许可证

别担心, 开心点.

坦率地说, 生活太短暂了, 不值得为法律问题烦恼, 所以

你可以对这本书里的代码做任何你想做的事;
如果代码不工作, 别怪我.

4.9.1. 免责声明

本软件由作者和贡献者“按原样”提供, 不提供任何明示或暗示的保证, 包括但不限于对适销性和特定用途适用性的暗示保证. 在任何情况下, 作者或贡献者均不对任何直接、间接、偶然、特殊、惩戒性或后果性损害 (包括但不限于采购替代商品或服务; 使用、数据或利润的损失; 或业务中断) 承担责任, 无论其原因和责任理论如何, 无论是在合同、严格责任或侵权 (包括疏忽或其他) 方面, 以任何方式因使用本软件而引起的, 即使已被告知此类损害的可能性.

Footnotes:

我们稍后将研究为什么 true 会归约为 {closure (value)}.

在谓词名称后附加一个 “p” 是古老的 LISP 传统, 但 zenlisp 以相当宽松的方式遵循这一传统.

(define (listp x)
  (cond ((null x) :t)
        ((atom x) :f)
        (t (listp (cdr x)))))

Listp 使用 atom 谓词, 该谓词测试其参数是否是原子的. 任何不能被 (通过 car 或 cdr) 分割的东西都是原子的:

(car 'symbol) => bottom
(car ()) => bottom
(cdr 'symbol) => bottom
(cdr ()) => bottom

让我们将 listp 应用于一些数据:

(listp ()) => :t
(listp '(banana split)) => :t
(listp '#abcde) => :t

好的, 现在来一些反例:

(listp 'banana) => :f
(listp '(heads . tails)) => :f

'Banana 显然不是一个列表, '(heads . tails) 的尾部也不是.

这些呢:

(listp '(define (f x) x)) => :t
(listp '(x (((y . z))) ())) => :t

是的, 列表可以包含对和列表, 它们可以嵌套到任何级别.

还有这个?

(listp (append '#abcde 'x)) => :f

无论将一个符号附加到一个列表会得到什么, 它都不是一个列表:

(append '#abcde 'x) => '(a b c d e . x)

得到的结构是点对和列表的混合体; 它被称为点列表 (dotted list). (有时也称为不当列表 (improper list), 因为“适当”的列表以 () 结尾.)

因为列表是对, 所以函数 caar…cddddr 也可以用来提取列表的成员.

例如:

(caar '((first) (second) (third))) => 'first
(cadr '((first) (second) (third))) => '(second)
(cdar '((first) (second) (third))) => '()
(cddr '((first) (second) (third))) => '((third))
(caddr '((first) (second) (third))) => '(third)
(cdddr '((first) (second) (third))) => ()
(caaddr '((first) (second) (third))) => 'third

编写 filter 的尾递归版本留作读者的练习.

(define (filter p lst)
  (cond ((null lst) ())
        ((p (car lst))
         (cons (car lst)
               (filter p (cdr lst))))
        (t (filter p (cdr lst)))))

Filter 是一个高阶函数, 因为它期望一个函数 —— 准确地说是一个谓词 —— 放在 p 的位置. 它提取满足该谓词的列表成员:

(filter atom '(orange '#xyz juice (a . b))) => '(orange juice)

一个移除所有具有给定属性的元素的负过滤器可以基于 filter 使用闭包来实现:

(define (remove p lst)
  (filter (lambda (x) (not (p x)))
          lst))
(remove atom '(orange #xyz juice (a . b))) => '(#xyz (a . b))

Not 实现了逻辑“非”:

(define (not x) (eq x :f))

函数

(lambda (x) (not (p x)))

本身就是一个有用的高阶函数. 这是一个稍微改进的版本:

(define (complement p)
  (lambda x (not (apply p x))))

它将一个谓词变成它的补:

(atom 'x) => :t
((complement atom) 'x) => :f
(eq 'apple 'orange) => :f
((complement eq) 'apple 'orange) => :t

⁴

+ 计算列表的和, max 提取列表的最大值. '#0 是 zenlisp 表达数字 0 的方式.

(require '~nmath) ; load natural math package
(define (depth x)
  (cond ((atom x) '#0)
        (t (+ '#1 (apply max (map depth x))))))

Map 可以将函数映射到任意数量的列表上:

(map car '(#ab #cd #ef)) => '#ace
(map cons '#ace '#bdf) => '((a . b) (c . d) (e . f))
(map (lambda (x y z) (append x '#- y '#- z))
     '(#lemon #cherry)
     '(#chocolate #banana)
     '(#ice-cream #shake))
=> '(#lemon-chocolate-ice-cream
     #cherry-banana-shake)

Map-car 是 map 的一个简化版本, 只接受一元函数 (单变量函数) 和单个列表:

(define (map-car f a)
  (letrec
    ((map-car2
       (lambda (a r)
         (cond ((null a) (reverse r))
               (t (map-car2 (cdr a)
                            (cons (f (car a)) r)))))))
    (map-car2 a ())))

any-null 谓词检查列表中包含的数据是否有任何一个等于 ():

(define (any-null lst)
  (apply or (map-car null lst)))

将 null 映射到一个列表会得到一个真值列表:

(map-car null '(#x #y () #z)) => '(:f :f :t :f)

将 or 应用于结果列表, 如果列表中至少有一个成员不是 :f, 则得到真.

car-of 和 cdr-of 函数分别将列表的列表映射到 car 和 cdr 部分的列表:

(define (car-of x) (map-car car x))
(define (cdr-of x) (map-car cdr x))

Any-null, car-of 和 cdr-of 用于实现 map:

(define (map f . a)
  (letrec
    ((map2
       (lambda (a b)
         (cond ((any-null a) (reverse b))
               (t (map2 (cdr-of a)
                        (cons (apply f (car-of a)) b)))))))
    (map2 a ())))

因为 any-null 检查其参数的任何子列表是否为 (), 所以 map 在到达传递给它的最短列表的末尾时立即返回:

(map cons '#ab '#abcd) => '((a . a) (b . b))

⁵

predicate-iterator 函数有一个小缺陷. 详见第 55 页.

(define (predicate-iterator pred)
  (let ((:fail ':fail))
    (let ((compare
           (lambda (a b)
             (cond ((eq a :fail) :fail)
                   ((pred a b) b)
                   (t :fail)))))
      (lambda (first . rest)
        (neq (fold compare first rest) :fail)))))

这是 predicate-iterator 的实际应用:

(define eq* (predicate-iterator eq))
(eq*) => bottom
(eq* 'lemon) => :t
(eq* 'lemon 'lemon) => :t
(eq* 'lemon 'lemon 'lemon) => :t
(eq* 'lemon 'lemon 'orange 'lemon) => :f

eq* 应用于少于两个参数时真的应该归约为 :t 吗? 如果不, 你将如何修复 predicate-iterator?

Fold 通过左结合 (left-associatively) 的方式组合其成员来归约列表:

(fold f 'a '(b c d)) = (f (f (f a b) c) d)

如果同一操作符的多次应用与左侧相关联, 即左侧结合得更紧密, 那么该操作是左结合的.

数学中的“减”操作符是左结合的, 因为 \[ a - b - c - d = (((a - b) - c) - d) \]

要右结合 (right-associatively) 地折叠列表成员, 使用 fold-r 函数:

(fold-r f 'a '(b c d)) = (f a (f b (f c d)))

右结合操作符的一个例子是数学中的幂运算: \[ a^{b^{c^d}} = a^{(b^{(c^d)})} \] 以下归约说明了 fold 和 fold-r 之间的区别.

(fold cons 'a '(b c d)) => '(((a . b) . c) . d)
(fold-r cons 'a '(b c d)) => '(b . (c . (d . a)))
= '(b c d . a)

⁶

x 的“floor”表示不大于 x 的最大整数.

(cond ((zero rem) '#0)
      ((eq (negative a) (negative b))
       rem)
      (t (+ b rem)))))

negative 谓词测试其参数 (必须是数值) 是否为负数.

Eq 在 modulo 中用作逻辑等价运算符:

(eq (negative a) (negative b))

如果 a 和 b 都是正数或都是负数, 则归约为真.

⁷

如果你真的尝试这个, 你将不得不重新启动 zenlisp 来恢复原始行为.

(define define :f) => 'define
(define define :f) => bottom

因为 define 的第一次应用将 define 本身的值更改为 :f, 所以第二个形式甚至不是一个有效的表达式.

有副作用的函数是伪函数, 但并非每个伪函数都有副作用. Cond, quote, let 和 lambda 是没有副作用的伪函数的例子.

⁸

在这个例子中, 参数列表被压缩了, 因为这是 zenlisp 打印机打印它们的方式. 然而, 这对语义没有影响. 例如, (lambda (x) (x x)) 等于 (lambda #x #xx).

((lambda #x (list x (list 'quote x)))
 '(lambda #x (list x (list 'quote x))))
=> ((lambda #x (list x (list 'quote x)))
    '(lambda #x (list x (list 'quote x))))

这种程序广为人知, 称为 quine. 它们以哲学家 W.V.O. Quine 的名字命名, 他在间接自引用领域做了大量研究.

上面的程序将它代码的引用“一半”插入到形式

(list x (list 'quote x))

中的 x 的位置, 从而创建了将这一半应用于其自身的引用副本的代码. 自引用是间接的, 因为表达式不引用自身, 而是创建一个对自身的引用.

这是另一个经典的自引用表达式:

((lambda #x #xx) (lambda #x #xx))

你能推断出它的范式吗? 它有吗?

⁹

Zenlisp 会将 '(s y m b o l) 打印为 '#symbol.

(explode 'symbol) => '(s y m b o l)

Lambda-rename 在一个关联列表中保存新旧名称的替换, 例如:

'((y . y:1) (x . x:0))

Ext-sub 接受一个变量名列表、一个 alist 和一个数字. 它为每个传递给它的变量名添加一个新的替换:

(ext-sub '((x . x:2)) '(a b c) '#3)
=> '((c . c:3) (b . b:3) (a . a:3) (x . x:2))

这是 ext-sub:

(define (ext-sub sub vars level)
  (letrec
    ((add-var
       (lambda (name alist)
         (cons (cons name (add name level))
               alist))))
    (cond ((null vars) sub)
          ((atom vars) (add-var vars sub))
          (t (ext-sub (add-var (car vars) sub)
                      (cdr vars)
                      level)))))

Ext-sub 正确处理可变参数列表:

(ext-sub '() '(x . y) '#1) => '((y . y:1) (x . x:1))

subst 函数类似于 assoc:

(define (subst name sub)
  (let ((v (assq name sub)))
    (cond (v (cdr v))
          (t name))))

它与 assoc 的唯一区别是, 在成功的情况下它返回值, 如果没有找到匹配的关联, 则返回键:

(subst 'x '((x . x:0))) => 'x:0
(subst 'cons '((x . x:0))) => 'cons

Rename-vars 遍历一个代表表达式的数据, 并重命名其参数列表和主体中 lambda 函数的所有变量:

(define (rename-vars expr sub level)
  (cond ((atom expr) (subst expr sub))
        ((eq (car expr) 'quote) expr)
        ((eq (car expr) 'lambda)
         (let ((vars (cadr expr))
               (body (caddr expr)))
           (let ((new-sub (ext-sub sub vars level)))
             (list 'lambda
                   (rename-vars vars new-sub level)
                   (rename-vars body
                                new-sub
                                (+ '#1 level))))))
        (t (map-car-i (lambda (x)
                        (rename-vars x sub level))
                      expr))))

因为 rename-vars 必须能够处理 lambda 的可变参数列表, 所以它不能通过 map 递归. 它使用了一个特殊版本的 map-car [page 44], 能够处理点分 (不当) 列表 (因此其名称中有尾随的“i”):

(define (map-car-i f a)
  (letrec
    ((map-car-i2
       (lambda (a r)
         (cond ((null a) (reverse r))
               ((atom a) (append (reverse r) (f a)))
               (t (map-car-i2 (cdr a)
                              (cons (f (car a)) r)))))))
    (map-car-i2 a ())))

rename-vars 的两个参数是常量, 所以这里有一个提供它们的包装器:

(define (lambda-rename expr)
  (rename-vars expr () '#0))

在使用 lambda-rename 重命名 lambda 表达式的变量后, beta 归约只不过是一个简单的替换.

subst-vars 函数用与该符号关联的值替换给定表达式的每个符号:

(define (subst-vars expr sub)
  (cond ((atom expr) (subst expr sub))
        ((eq (car expr) 'quote) expr)
        (t (map-car-i (lambda (x)
                        (subst-vars x sub))
                      expr))))

使用 lambda-rename 和 subst-vars, 无需使用闭包即可完成 beta 归约:

(define (beta-reduce app)
  (let ((app (lambda-rename app)))
    (let ((vars (cadar app))
          (args (cdr app))
          (body (caddar app)))
      (subst-vars body (map cons vars args)))))

beta-reduce 不创建闭包, 而是用它们的值替换自由变量:

(beta-reduce '((lambda (x) x) v))
=> 'v
(beta-reduce '((lambda (f) (lambda (x) (f x))) not))
=> '(lambda (x:1) (not x:1))
(beta-reduce '((lambda (x) (list x (lambda (x) x))) v))
=> '(list v (lambda (x:1) x:1))

你可以使用 eval 来解释元程序的输出:

(eval (beta-reduce '((lambda (x) (list x (lambda (x) x))) 'v)))
=> '(v {closure (x:1) x:1})

¹⁰

这种方法在现实世界中也有效. 通过将大批人分成小团体, 权力饥渴的小团体可以轻易地控制这些人. 广告和“新闻”是典型的现实世界分而治之的工具. 我们能做些什么呢?

(require 'partition)
(define (quicksort p a)
  (letrec
    ((sort
       (lambda (a)
         (cond ((or (null a) (null (cdr a))) a)
               (t (let ((p* (partition (lambda (x) (p (car a) x))
                                       (cdr a))))
                    (append (sort (cadr p*))
                            (list (car a))
                            (sort (car p*)))))))))
    (sort a)))

当快速排序对一个列表进行排序时, 它首先将该列表分成更小的列表, 一个包含低于给定阈值的成员, 一个包含高于该阈值的成员. 可以使用 trace 元函数来观察其内部工作:

(trace sort) => :t
(quicksort < '(#5 #1 #9 #3 #7))
+ (sort (#5 #1 #9 #3 #7))
+ (sort (#1 #3))     ; sort members <5
+ (sort ())          ; sort members <5 and <1
+ (sort (#3))        ; sort members <5 and >1
+ (sort (#9 #7))     ; sort members >5
+ (sort (#7))        ; sort members >5 and <9
+ (sort ())          ; sort members >5 and >9
=> '(#1 #3 #5 #7 #9)

在对所有分区进行排序后, 快速排序使用 append 重新组装它们:

(trace append) => :t
(quicksort < '(#5 #1 #9 #3 #7))
+ (append () (#1) (#3))
+ (append (#7) (#9) ())
+ (append (#1 #3) (#5) (#7 #9))
=> '(#1 #3 #5 #7 #9)

注意, 快速排序本身从不应用谓词 p. 列表通过一次又一次地对其进行分区来排序:

(partition (lambda (x) (p '#5 x))
           '(#1 #9 #3 #7))
=> '((#9 #7) (#1 #3))

在对列表 '(#1 #9 #3 #7) 进行分区后, 第一个分区只包含小于 5 的值, 第二个分区只包含大于 5 的值. 这些分区被递归地排序, 然后连接起来 (连同阈值本身).

'() '#1 '(#3) '#7 '#9 '() '() '#1 '(#3) '#7 '#9 '() '#5 '#1 #3 '#9 #7 '#5 #1 #9 #3 #7

图 1 说明了分治范式. 原始列表被递归地分解成更小的列表, 直到这些更小的列表可以轻松排序, 因为它们要么是空的, 要么只包含单个值. 直箭头表示分区, 灰色框包含阈值. 弯曲的箭头表示 append 操作.

快速排序与 isort 相比如何？当对已经排序和反向排序的输入进行排序时, 快速排序的性能如何？

¹¹

然而, mergesort 在表中表现出对已排序数据的轻微偏好. 你能解释一下吗？

同样值得注意的是, 插入排序在随机和已排序集合上表现极差, 却在反向排序集合的排序方面表现出色. 在这种情况下, 它甚至比其他两种算法更有效率. 事实上, 以下算法比其他两种排序算法更适合将少量数据插入到已排序的列表中:

(define (insert-small-set p small sorted)
  (isort p (append small (reverse sorted))))

对于更大的集合, 应使用 mergesort 代替 isort, 并应省略 reverse. 随意探索在切换到 Mergesort 变得必要之前插入集合大小的合理限制.

当查看比较排序随机数据所需步骤的列 (在图 2 中以粗体字符打印) 时, 你可能会注意到单个数字对排序算法的质量说明不了什么. 有趣的是这些数字随着输入集大小的增加而发展.

这种发展被称为函数的复杂度 (complexity). 图 3 以图表的形式呈现了本节讨论的排序函数的复杂度. x 轴表示要排序的随机集的大小, y 轴表示对给定集进行排序所需的步骤.

从图中可以看出, 插入排序的运行时间随着集合大小的增加而迅速增长, 而快速排序和归并排序的运行时间增长缓慢. 平坦的曲线表示高效率, 陡峭的曲线表示性能差.

复杂度可以用所谓的大O表示法 (big-O notation) 来表示, 而无需使用曲线: $O(n \times 5)$ 可以解释为“当输入增加 1 时, 所述算法的运行时间乘以 5”. 大O表示法可以描述算法的空间和时间需求. 在本节中, 我们专注于时间.

插入排序的平均 (时间) 复杂度是 $O(n^2/2)$, 而快速排序和归并排序的 (平均) 复杂度是 $O(n \times \log(n))$. 正如我们所见, 快速排序的最坏情况性能是 $O(n^2/2)$ (像插入排序), 而归并排序的最坏情况性能 (大约) 等于其平均性能.

大O表示法的重要部分是公式本身, 而不是它们的系数. 例如, $O(n \times 10000)$ 通常比 $O(1.1^n)$ 好得多, 尽管前者的系数要大得多. 对于较小的 n 值, 后者确实更有效率: \[ O(10 \times 10000) = 100000 \] \[ O(1.1^{10}) = 2.5 \] 在 n=150 时, 它们几乎持平: \[ O(150 \times 10000) = 1500000 \] \[ O(1.1^{150}) = 1617717.8 \] 但在 n=1000 时, 情况完全不同: \[ O(1000 \times 10000) = 100000000 \] \[ O(1.1^{1000}) = 246993291800582633412408838508522147770973.3 \] $O(c \times n)$ (其中 c 是常数) 描述了“线性”复杂度, 这是“非常好”的, 而 $O(c^n)$ 表示“指数”复杂度, 这在大多数情况下意味着它描述的算法要么接近无法使用, 要么它试图解决的问题非常困难.

图 4 概述了从最好到最差的不同复杂度类别.

Table 3: Fig. 4 – classes of complexity
formula	name
$O(c)$	constant
$O(c \times \log(n))$	logarithmic
$O(c \times n)$	linear
$O(c \times n^2)$	quadratic
$O(n^c)$	polynomial or geometric
$O(c^n)$	exponential

顺便说一句: unsort 函数在平均情况和最坏情况下的复杂度是多少？(Q9)

你认为它可以改进吗？

¹²

Id 定义为 (lambda #x x).

(define (combine n set)
  (combine3 n set cdr))
(define (combine* n set)
  (combine3 n set id))

combine3 使用哪种递归？

combine 和 combine* 的复杂度有区别吗？估计它们的复杂度. (Q11)

¹³

朴素函数是: (define (f x) (cond ((zero x) '#1) (t (* x (f (- x '#1)))))).

¹⁴

ML (“Meta Language”) 是 1973 年由 Robin Milner 等人在爱丁堡大学发明的静态类型函数式编程语言. 它可能是第一个采用“类型推断”的语言. 另见: http://www.smlnj.org.

(or (defined 'nmath)
    (defined 'imath)
    (defined 'rmath)
    (load ~rmath))

为了将记录与其他数据类型区分开来, 创建了数据 '(%record) 的一个唯一实例 [page 55]. 这个数据将用于标记记录.

(define record-tag (list '%record))

下面的过程确定给定形式的类型. 注意, 闭包和记录同时也是列表. 在 zenlisp 中无法实现更严格的类型检查.

(define (pair-p x) (not (atom x)))

(define (boolean-p x)
  (or (eq x :t)
      (eq x :f)))

(define (closure-p x)
  (and (pair-p x)
       (eq (car x) 'closure)))

(define (record-p x)
  (and (pair-p x)
       (eq (car x) record-tag)))

List->record 将一个由两个元素组成的列表 (标签/值元组) 的列表转换为一个记录:

(list->record '((food marmelade) (type processed)))
=> ((%record) (food marmelade) (type processed))
(list->record '(foo bar))
=> bottom

它还检查这些对是否具有适当的格式, 但不检查重复的标签. 随意改进代码.

(define (list->record a)
  (letrec
    ((valid-fields-p
       (lambda (a)
         (or (null a)
             (and (pair-p (car a))
                  (atom (caar a))
                  (pair-p (cdar a))
                  (null (cddar a))
                  (valid-fields-p (cdr a)))))))
    (cond ((valid-fields-p a) (cons record-tag a))
          (t (bottom 'bad-record-structure a)))))

record 函数是主要的记录构造器. 它从一组标签/值元组中组装一个记录:

(record '(foo bar) '(baz goo)) => ((%record) (foo bar) (baz goo))

它基于 list->record, 但在构造记录之前会评估其各个参数:

(define (record . x) (list->record x))

注意, 你不能创建像 '((%record) (foo bar)) 这样的记录字面量, 因为该结构的 (%record) 部分与绑定到 record-tag 的唯一实例不同一:

(record-p (record '(foo bar))) => :t
(record-p '((%record) (foo bar))) => :f

Record->list 是 list->record 的反向操作.

(define (record->list r)
  (cond ((record-p r) (cdr r))
        (t (bottom 'expected-record-got r))))

record-field 函数从一个记录中提取具有给定标签的字段, record-ref 提取与给定标签关联的值:

(record-field (record '(a #1) '(b #2)) 'b) => '(b #2)
(record-ref (record '(a #1) '(b #2)) 'b) => #2

当它们的第一个参数不是一个记录, 或者第二个参数在给定的记录中没有作为标签出现时, 它们都会归约为 bottom.

(define (record-field r tag)
  (let ((v (assq tag (record->list r))))
    (cond (v v)
          (t (bottom 'no-such-tag
                     (list 'record: r 'tag: tag))))))
(define (record-ref r tag) (cadr (record-field r tag)))

Type-of 返回一个指示给定形式类型的符号. 注意, list 不会出现在 type-of 中. 它对 pair (因此也对列表) 甚至空列表返回 'pair.

(define (type-of x)
  (cond ((boolean-p x) 'boolean)
        ((null x) 'pair)
        ((atom x) 'symbol)
        ((number-p x) 'number)
        ((record-p x) 'record)
        ((closure-p x) 'function)
        ((pair-p x) 'pair)
        (t (bottom 'unknown-type x))))

两个记录是相等的, 如果

它们有相同数量的字段;
它们的字段有相同的标签;
具有相同标签的字段有相等的值.

两个相等记录的字段不必以相同的顺序出现. 例如, 以下两个记录是相等的:

(record '(foo #1) '(bar #2))
(record '(bar #2) '(foo #1))

如果记录包含记录, 嵌入的记录会被递归地比较. record-equal 谓词比较记录:

(define (record-equal r1 r2)
  (letrec
    ((equal-fields-p
       (lambda (r1 r2)
         (cond ((null r1) :t)
               (t (let ((x (assq (caar r1) r2)))
                    (and x
                         (equal (cadar r1) (cadr x))
                         (equal-fields-p (cdr r1) r2))))))))
    (let ((lr1 (record->list r1))
          (lr2 (record->list r2)))
      (and (= (length lr1) (length lr2))
           (equal-fields-p lr1 lr2)))))

equal 谓词也被扩展以处理记录:

(define (equal a b)
  (cond ((eq a b) :t)
        ((and (pair-p a) (pair-p b))
         (and (equal (car a) (car b))
              (equal (cdr a) (cdr b))))
        ((record-p a)
         (and (record-p b)
              (record-equal a b)))
        (t :f)))

记录 r 的签名 (signature) 是另一个包含相同标签的记录, 但它包含的是 r 的值的类型, 而不是值本身, 例如:

(record-signature (record '(food apple) '(weight #550) '(vegetarian :t)))
=> '((%record) (food symbol) (weight number) (vegetarian boolean))

包含嵌入记录的记录具有递归签名:

(record-signature (record (list 'p1 (record '(x #0) '(y #0)))
                          (list 'p2 (record '(dx #0) '(dy #0)))))
=> '((%record) (p1 (record ((%record) (x number) (y number))))
                (p2 (record ((%record) (dx number) (dy number)))))

record-signature 函数创建记录的签名:

(define (record-signature r)
  (letrec
    ((make-sig
       (lambda (x)
         (map (lambda (x)
                (cond ((record-p (cadr x))
                       (list (car x)
                             (list (type-of (cadr x))
                                   (record-signature (cadr x)))))
                      (t (list (car x) (type-of (cadr x))))))
              x))))
    (list->record (make-sig (record->list r)))))

record-set 函数创建一个新的记录, 其中给定字段的值被替换为新值:

(define r (record '(food cucumber)))
r => '((%record) (food cucumber))

(record-set r 'food 'melon) => '((%record) (food melon))
r => '((%record) (food cucumber))

注意, record-set 不会改变原始记录. 当给定的标签在给定的记录中没有出现, 或者与标签关联的值与新值的类型不同时, record-set 会产生 bottom:

(record-set (record '(food salt)) 'zzz 'baz) => bottom ; unknown tag
(record-set (record '(food salt)) 'food :f) => bottom ; type mismatch

当替换类型为 record 的值时, 新旧值必须具有相同的签名:

(define r (record (list 'menu (record '(food apple)))))

(record-set r 'food (record '(food (x y z))))
=> bottom ; type mismatch, expected: ((%record) (food symbol))
                  got: ((%record) (food pair))

(record-set r 'menu (record '(food orange)))
=> '((%record) (menu ((%record) (food orange))))

这是 record-set 函数的代码.

(define (record-set r tag v)
  (letrec
    ((subst
       (lambda (r old new)
         (cond ((null r) ())
               ((eq old (car r))
                (cons new (cdr r)))
               (t (cons (car r)
                        (subst (cdr r) old new))))))
     (type-mismatch
       (lambda ()
         (bottom 'type-mismatch
                 (list 'record: r 'tag: tag 'value: v)))))
    (let ((f (record-field r tag)))
      (let ((b (cdr f)))
        (cond ((eq (type-of (car b)) (type-of v))
               (cond ((or (not (record-p v))
                          (record-equal
                            (record-signature (car b))
                            (record-signature v)))
                      (subst r f (list (car f) v)))
                     (t (type-mismatch))))
              (t (type-mismatch)))))))

因为 record-set 只替换类型匹配的值, 它使得记录像 ML 记录一样类型安全. 注意, 为了实现类型安全, 无需声明记录类型. 记录的类型是通过提取其签名来确定的.

显式的类型检查或分派可以通过 assert-record-type 和 record-type-matches-p 函数添加到函数中.

Record-type-matches-p 是一个谓词, 如果给定的记录匹配给定的签名, 则返回真. 它仅仅是一个缩写:

(define (record-type-matches-p sig r)
  (record-equal sig (record-signature r)))

它像这样使用:

(define point-type (record-signature (record '(x #0) '(y #0))))
...
(define (some-function x)
(cond ((record-type-matches-p point-type x)
       code handling point records...)
      (t code handling other types ...)))

Assert-record-type 类似, 但用于确保参数具有给定的类型:

(define (some-function r)
(function-expecting-a-point (assert-record-type point-type r)))

只要传递给 assert-record-type 的记录具有预期的签名, 该函数就简单地返回该记录. 当其类型不匹配时, 它会中止计算并归约为 bottom. 这是 assert-record-type 的代码:

(define (assert-record-type sig r)
  (cond ((not (record-type-matches-p sig r))
         (bottom 'record-type-assertion-failed
                 (list 'signature: sig 'record: r)))
        (t r)))

记录的签名有什么签名？记录的签名的签名呢？给出一些例子. (Q19)

当然, 记录类型在支持值突变的语言中最有用, 所以这个实现仅仅是一个概念证明. 你能想象本节代码的任何实际用途吗？

当将其移植到支持可变值 (如 Scheme) 的语言时, 你会应用哪些修改？

¹⁵

是的, 这就是为什么一组规则被称为“产生式”.

a     ----> 'a'
aa    ----> 'a' <a*> 'a'
aaa   ----> 'a' <a*> 'a' <a*> 'a'
aaaa  ----> 'a' <a*> 'a' <a*> 'a' <a*> 'a'
aaaaa ----> 'a' <a*> 'a' <a*> 'a' <a*> 'a' <a*> 'a'
...

说一个“产生式产生”一组句子意味着该产生式匹配这些句子. 一个产生式产生的句子集正是该产生式所接受的程序集.

递归的原则可以被用来, 例如, 形成具有任意数量操作数的 <sum>:

<sum> := symbol
       | symbol '+' <sum>
       | symbol '-' <sum>

这是此版本 <sum> 产生的一些句子:

x     ----> symbol
x+y   ----> symbol '+' <sum> symbol
x+y-z ----> symbol '+' <sum> symbol '-' <sum> symbol

上面的产生式 (几乎) 可以用来描述 infix->prefix 解析器所接受的语言的一部分. 然而, 解析器不仅会接受符号作为操作数, 还会接受数字, 并且它也会接受项和指数. 一个产生式不足以涵盖所有这些, 所以多个产生式将被组合成一个语法 (grammar). 以下语法接受一个语言, 其中数字和符号都可以作为和中的操作数:

<sum> := <factor>
       | <factor> '+' <sum>
       | <factor> '-' <sum>

<factor> := symbol
          | number

在现实世界的数学公式中, 像乘法和除法这样的运算“结合得更紧”, 例如, 比加法和减法. 编译器编写者会说乘法和除法比加法和减法有“更高的优先级” (higher precedence). 优先级在语法中很容易实现 (见上面 <factor> 的定义):

<term> := <factor>
        | <factor> '*' <term>

<sum> := <term>
       | <term> '+' <sum>

这里 <term> 的工作方式与前一个语法中的 <sum> 相同. <Sum> 现在由 <term> 组成. 因为在可以产生一个 <sum> 之前必须解析一个完整的 <term>, 所以 <term> 比 <sum> 结合得更紧密. 换句话说: 一个 <sum> 是一个 <term> 后跟可选的 <sum> 操作.

让我们根据这个语法检查一些直观上格式良好的句子:

x     ----> <sum> <term> <factor> 'x'
x+y   ----> <sum> <term> <factor> 'x' '+' <sum> <term> <factor> 'y'
x+y*z ----> <sum> <term> <factor> 'x' '+' <sum> <term> <factor> 'y'
                                           '*' <term> <factor> 'z'
x*y+z ----> <sum> <term> <factor> 'x' '*' <term> <factor> 'y'
            '+' <sum> <term> <factor> 'z'

好的, 这是事情变得有点混乱的地方, 因为线性表示并不真正适合表示句子. 这就是为什么解析器的输出通常以树形形式呈现的原因.

图 5 中的树显示了公式 x+y*z 的语法树. 语法树有时也称为解析树 (parse tree). 方框表示非终结符, 圆圈表示终结符. 沿着树的外边缘访问终结符的顺序与它们在原始公式中出现的顺序相同.

因为一个 <term> 可以是一个 <sum> 的一部分, 但一个 <sum> 永远不能是一个 <term> 的一部分, 所以 <term> 总是包含在 <sum> 树中, 因此, 当使用“深度优先”遍历树时, 项操作在和操作之前被访问. 由于这个顺序, 项操作比和操作具有更高的优先级.

树的深度优先遍历意味着子树总是在处理父节点之前被访问. 例如, 通过首先访问每个非终结节点的左分支, 然后访问右分支, 最后发出附加到该节点的终结符 (如果有的话), 可以将树转换为逆波兰表示法 (后缀表示法). 遍历上面的树会产生:

x y z * +

在进入分支之前发出操作数会产生前缀表示法:

+ x * y z

添加括号会得到一个 zenlisp 程序:

(+ x (* y z))

注意, 和和项运算符的优先级在所有表示法中都得以保留: 树、后缀和前缀.

我们现在知道如何定义语法, 表示已解析的文本, 甚至生成 zenlisp 程序. 缺少的是输入语言的完整语法. 它在这里:

<sum> := <term>
       | <term> '+' <sum>
       | <term> '-' <sum>

<term> := <power>
        | <power> '*' <term>
        | <power> <term>
        | <power> '/' <term>
<power> := <factor>
         | <factor> '^' <power>

<factor> := symbol
          | number
          | '-' <factor>
          | '[' <sum> ']'

infix-prefix 解析器接受的每个格式良好的句子都是 <sum> 的一个产生式. 注意规则

<term> := <power> <term>

允许将 x*y 缩写为 xy. 当然, 这只有在变量是单字母词素时才可能. 规则

<factor> := '[' <sum> ']'

给予一个 <sum> (无论它最终包含哪些运算符) <factor> 的优先级, 从而允许像数学公式中那样对子表达式进行分组. 还要注意, 负号前缀 (它对一个因子取反) 具有最高的优先级, 所以

-x^2

实际上意味着

(-x)^2

现在 infix->prefix 解析器的语法已经形式化地指定了, 就没有必要再依赖直觉了, 解析器的实现也相当直接.

嗯, 几乎是直接的. 还有一个微妙的细节需要讨论.

¹⁶

Unix 风格的 RE 会使用点 (.) 而不是下划线 (_), 但这在 zenlisp 中无法做到, 因为点是为点对保留的.

_ [ ] ^ $ * + ? \

当要字面匹配这些字符之一时, 必须在它前面加上一个反斜杠 (\). 否则它将被解释为一个运算符. 运算符的含义如下:

Operator	Meaning
[c1…]	字符类匹配方括号中包含的任何字符.
[^c1…]	当括号之间的第一个字符是 ^ 时, 该类匹配任何不包含在其中的字符.
[c1-c2 …]	当类中出现减号时, 它被替换为减号前面的字符和减号后面的字符之间的字符, 例如: [0-9] 扩展为.
_	这是包含所有字符的类, 所以它匹配任何字符.
^	匹配序列的开头.
$	匹配序列的结尾.
*	匹配前一个字符或类的零次或多次出现.
+	匹配前一个字符或类的至少一次出现.
?	匹配前一个字符或类的零次或一次出现.
\c	字面匹配字符 c, 即使它是一个运算符.

这里有一些 RE 示例:

[A-Za-z]+         匹配任何字母序列
[A-Za-z]+[0-9]*    匹配任何字母序列, 后跟一个可选的数字序列
[a-z][0-9]?       匹配任何小写字母, 后跟一个可选的数字
_*                匹配任何长度的任何序列 (甚至空序列)
_+                匹配任何长度的任何序列 (但非空)
\**               匹配任何星号序列

以下代码包含两个用于正则表达式匹配的函数: re-compile 和 re-match. Re-compile 将 RE 编译为一种更适合高效匹配的格式. 编译后的格式称为 CRE (编译后的 RE):

(re-compile RE) => CRE

re-match 函数将一个 CRE 与一个字符序列进行匹配. 它返回匹配 CRE 的子序列, 如果序列不匹配, 则返回 :f:

(re-match (re-compile '#[a-z]*) '#___abc___) => '#abc
(re-match (re-compile '#[0-9]*) '#___abc___) => :f

匹配器使用首次匹配和最长匹配优先策略. 首次匹配意味着给定多个潜在匹配, 它返回第一个:

(re-match (re-compile '#[a-z]*) '#_abc_def_) => '#abc

最长匹配优先意味着每个匹配子序列的运算符 (如 * 和 +) 都会尝试匹配尽可能多的字符 (这种方法也称为贪婪匹配): ¹⁷

¹⁷

最长匹配优先的方法现在也称为“贪婪”匹配, 但我认为这个术语不幸, 因为它传播了一种破坏性的心态, 这种心态已经在我们的星球上造成了足够的痛苦.

(re-match (re-compile '#x_*x) '#x___x___x) => '#x___x___x

另一种策略 (称为最短匹配优先或惰性匹配) 将尝试找到匹配 RE 的最短可能字符串. 使用这种方法, 上面的表达式将返回 '#x___x.

如上所示, zenlisp RE 匹配器使用单字符符号列表来表示字符序列. 当然, 这意味着它只能使用有限的字符集, 但基本原理与例如 grep 实用程序中的相同.

由于缺少“文本行”的概念, 本节中的 ^ 和 $ 运算符表示序列的开始和结束:

(re-match (re-compile '#[a-z]*) '#12test34) => '#test
(re-match (re-compile '#^12[a-z]*) '#12test34) => '#12test
(re-match (re-compile '#[a-z]*34$) '#12test34) => '#test34
(re-match (re-compile '#^[a-z]*$) '#12test34) => :f

¹⁸

全文可在 McCarthy 的主页上找到: http://www-formal.stanford.edu/jmc/history/lisp/lisp.html

S.R. Russel 注意到 eval 可以作为 LISP 的解释器, 立即手动编码了它, 我们现在有了一个带解释器的编程语言. 解释器的意外出现倾向于冻结语言的形式 […]

精确定义 M-表达式并编译它们或至少将它们翻译成 S-表达式的项目既没有最终确定也没有被明确放弃. 它只是退居到不确定的未来, 新一代的程序员出现了, 他们更喜欢内部表示法, 而不是任何可以设计的类似 FORTRAN 或 ALGOL 的表示法.

所以 M-表达式的语法从未被精确地指定过. 然而, 许多 LISP 文本都使用了 M-表达式, 所以可以从中收集到足够的信息来构建一种可能接近 M-表达式本来面貌的语言. 本章定义了 M-表达式的 BNF 语法, 并实现了一个将 M-表达式翻译成 S-表达式 (zenlisp 程序) 的编译器.

¹⁹

Friedmann, Byrd, Kiselyov; "The Reasoned Schemer"; MIT Press, 2005

Amk 可以被认为是其自身的语言. 它是一种逻辑编程语言 — 像 PROLOG — 而不是一种函数式编程语言. 然而, 它无缝地集成到 zenlisp 中: zenlisp 数据可以传递给 amk, 而 amk 返回普通的 S-表达式作为其结果.

为了在 zenlisp 程序中使用 amk, 必须通过在程序开头使用以下表达式来加载 amk 包:

(require '~amk)

²⁰

zenlisp 的祖先是用 T3X 而不是 C 编写的, 这可能解释了一些看起来不像 C 的决定.

Line 是相对于当前输入文件开头的当前输入行号. Output 是所有解释器输出 (包括错误消息, 但不包括启动错误消息) 发送到的输出流.

char *Infile;
FILE *Input;
int Rejected;
int Line;
FILE *Output;

以下字符串变量用于在加载程序时缓冲路径名. Source_dir 是加载源文件的目录, Expanded_path 用于展开以波浪号开头的文件名, 而 Current_path 在嵌套加载中捕获当前路径. 详见 load() 函数.

char Source_dir[MAX_PATH_LEN];
char Expanded_path[MAX_PATH_LEN];
char Current_path[MAX_PATH_LEN];

当 (致命) 错误发生时, Error_flag 和 Fatal_flag 被设置.

int Error_flag;
struct Error_context
 Error;
int Fatal_flag;

Symbols 是全局符号表. Safe_symbols 是符号表的一个副本, 用于在归约过程中出现严重错误时存储一个正常的副本.

因为 zenlisp 使用浅绑定 (直接在变量中存储值), 所以符号表只是一个符号列表.

int Symbols;
int Safe_symbols;

这些是解释器在将表达式归约为其范式时使用的各种栈:

Stack	Meaning
Stack	general-purpose stack
Stack_bottom	bottom of Stack, because eval() is reentrant
Mode_stack	interpreter states
Arg_stack	function arguments
Bind_stack	bindings of let and letrec
Env_stack	lexical environments of closures (performance hack)

int Stack, Stack_bottom;
int Mode_stack;
int Arg_stack;
int Bind_stack;
int Env_stack;

这些变量用于错误报告和调试:

int Frame;
int Function_name;
int Traced_fn;

Root 包含所有其值在垃圾回收期间需要被保护的变量. 回收器永远不会回收绑定到这些变量中任何一个的值.

int *Root[] = { &Symbols, &Stack, &Mode_stack, &Arg_stack, &Bind_stack,
                &Env_stack, &Tmp_car, &Tmp_cdr, &Tmp, &Tmp2,
                &Safe_symbols, NULL };

这些变量用于捕获词法环境. Lexical_env 持有要构建的词法环境. Bound_vars 包含在给定上下文中绑定的变量列表.

int Lexical_env;
int Bound_vars;

下一个变量用于跟踪输入中括号的嵌套级别以及 load 和 eval() 的应用. eval() 函数在程序归约期间内部递归, 但一些函数 (如 define) 仅限于递归的顶层.

int Paren_level;
int Load_level;
int Eval_level;

当 Quotedprint 设置为 1 时, 打印的表达式被假定为已经被引用, 所以不会打印前导引号 (撇号). Max_atoms_used 记录归约期间节点使用的峰值. 它由 gc 函数清除. Max_trace 持有在发生错误时在调用跟踪中打印的最大函数名数量.

int Quotedprint;
int Max_atoms_used;
int Max_trace;

当 Stat_flag 设置时, 会计算归约步骤、分配的节点和垃圾回收. 它由 stats 伪函数在内部使用. Closure_form 决定了一个闭包将打印多少. 0 表示只打印参数, 1 包括主体, 2 包括词法环境. Verify_arrows 打开和关闭箭头验证. Verbose_GC 控制 GC 统计信息的输出.

int Stat_flag;
int Closure_form;
int Verify_arrows;
int Verbose_GC;

这些是 stats 伪函数的计数器.

struct counter Reductions,
               Allocations,
               Collections;

以下变量持有常用符号的偏移量, 因此每次引用它们时都不必在符号表中查找它们. 一些符号是内部的, 一些是 zenlisp 关键字.

int S_bottom, S_closure, S_false, S_lambda, S_primitive,
    S_quote, S_special, S_special_cbv, S_true, S_void,
    S_last;

这些是 zenlisp 原始函数的 opcode. 它们是 Primitives 数组的偏移量, 该数组持有指向实现相关操作的函数的指针.

enum { P_ATOM, P_BOTTOM, P_CAR, P_CDR, P_CONS, P_DEFINED, P_EQ,
       P_EXPLODE, P_GC, P_IMPLODE, P_QUIT, P_RECURSIVE_BIND,
       P_SYMBOLS, P_VERIFY_ARROWS, N_PRIMITIVES };

int (*Primitives[N_PRIMITIVES])(int);

伪函数应用 (特殊形式) 的处理方式与原始函数相同.

enum { SF_AND, SF_APPLY, SF_CLOSURE_FORM, SF_COND, SF_DEFINE,
       SF_DUMP_IMAGE, SF_EVAL, SF_LAMBDA, SF_LET, SF_LETREC,
       SF_LOAD, SF_OR, SF_QUOTE, SF_STATS, SF_TRACE,
       N_SPECIALS };

int (*Specials[N_SPECIALS])(int, int *, int *, int *);

阻止 lint 抱怨未使用的变量.

#ifdef LINT
#define USE(arg) (arg = NIL)
#else
#define USE(arg)
#endif

程序中的每个函数都有一个原型. 请随意跳过.

int _rdch(void);
int add_primitive(char *name, int opcode);
int add_special(char *name, int opcode, int cbv);
int add_symbol(char *s, int v);
int alloc3(int pcar, int pcdr, int ptag);
int aunsave(int k);
int bad_argument_list(int n);
void bind_args(int n, int name);
int bunsave(int k);
void catch_int(int sig);
void clear_stats(void);
void collect_free_vars(int n);
int cond_get_pred(void);
int cond_eval_clause(int n);
int cond_setup(int n);
int copy_bindings(void);
void count(struct counter *c, int k);
char *counter_to_string(struct counter *c, char *buf);
int define_function(int n);
int dump_image(char *p);
int equals(int n, int m);
void eliminate_tail_calls(void);
int error(char *m, int n);
int eval(int n);
char *expand_path(char *s, char *buf);
int explode_string(char *sym);
void fatal(char *m);
int find_symbol(char *s);
void fix_all_closures(int b);
void fix_cached_closures(void);
void fix_closures_of(int n, int bindings);
int flat_copy(int n, int *lastp);
int gc(void);
int get_opt_val(int argc, char **argv, int *pi, int *pj, int *pk);
void get_options(int argc, char **argv);
void get_source_dir(char *path, char *pfx);
char *symbol_to_string(int n, char *b, int k);
void help(void);
void init(void);
void init1(void);
void init2(void);
int is_alist(int n);
int is_bound(int n);
int is_list_of_symbols(int m);
void let_bind(int env);
int let_eval_arg(void);
int let_finish(int rec);
int let_next_binding(int n);
int let_setup(int n);
int load(char *p);
int make_closure(int n);
void mark(int n);
int make_lexical_env(int term, int locals);
char *make_zen_path(char *s);
int munsave(void);
void nl(void);
void print(int n);
int reverse_in_situ(int n);
void pr(char *s);
int primitive(int *np);
void print_call_trace(int n);
int print_closure(int n, int dot);
int print_condensed_list(int n, int dot);
int print_primitive(int n, int dot);
int print_quoted_form(int n, int dot);
void print_trace(int n);
void print_license(void);
void pr_num(int n);
int quote(int n);
int read_condensed(void);
void read_eval_loop(void);
int read_list(void);
int read_symbol(int c);
void repl(void);
void reset_counter(struct counter *c);
void reset_state(void);
void restore_bindings(int values);
int setup_and_or(int n);
int special(int *np, int *pcf, int *pmode, int *pcbn);
int string_to_symbol(char *s);
char *symbol_to_string(int n, char *b, int k);
void unbind_args(void);
int unreadable(void);
int unsave(int k);
void usage(void);
void verify(void);
int wrong_arg_count(int n);
int z_and(int n, int *pcf, int *pmode, int *pcbn);
int z_apply(int n, int *pcf, int *pmode, int *pcbn);
int z_atom(int n);
int z_bottom(int n);
int z_car(int n);
int z_cdr(int n);
int z_closure_form(int n, int *pcf, int *pmode, int *pcbn);
int z_cond(int n, int *pcf, int *pmode, int *pcbn);
int z_cons(int n);
int z_define(int n, int *pcf, int *pmode, int *pcbn);
int z_defined(int n);
int z_dump_image(int n, int *pcf, int *pmode, int *pcbn);
int z_eq(int n);
int z_eval(int n, int *pcf, int *pmode, int *pcbn);
int z_explode(int n);
int z_gc(int n);
int z_implode(int n);
int z_lambda(int n, int *pcf, int *pmode, int *pcbn);
int z_let(int n, int *pcf, int *pmode, int *pcbn);
int z_letrec(int n, int *pcf, int *pmode, int *pcbn);
int z_load(int n, int *pcf, int *pmode, int *pcbn);
int z_or(int n, int *pcf, int *pmode, int *pcbn);
int z_quit(int n);
int z_quote(int n, int *pcf, int *pmode, int *pcbn);
int z_recursive_bind(int n);
int z_stats(int n, int *pcf, int *pmode, int *pcbn);
int z_symbols(int n);
int z_trace(int n, int *pcf, int *pmode, int *pcbn);
int z_verify_arrows(int n);
int zen_eval(int n);
void zen_fini(void);
int zen_init(int nodes, int trackGc);
char **zen_license(void);
int zen_load_image(char *p);
void zen_print(int n);
void zen_print_error(void);
int zen_read(void);
void zen_stop(void);
int zread(void);

²¹

是的, zenlisp 数字可以使用 append 附加, 因为它们是普通的列表.

(n-divide natural1 natural2) ----> '(quotient remainder)

(define (n-divide a b)
  (letrec
    ; Equalize the divisor B by shifting it to the left
    ; (multiplying it by 10) until it has the same number
    ; of digits as the dividend A.
    ; Return: (new divisor . base 1 shift count)
    ((eql
       (lambda (a b r s)
         (cond ((null a)
                (cons (reverse r) s))
               ((null b)
                (eql (cdr a)
                     ()
                     (cons 0 r)
                     (cons 'i s)))
               (t (eql (cdr a)
                       (cdr b)
                       (cons (car b) r)
                       s)))))
     ; Divide with quotient < 10
     ; Return (A/B*B . A/B)
     (div10
       (lambda (a b r)
         (cond ((n< (car r) a)
                (div10 a b (cons (n+ (car r) b)
                                 (n+ (cdr r) '#1))))
               ((equal (car r) a) r)
               (t (cons (n- (car r) b)
                        (n- (cdr r) '#1))))))
     ; X / 10
     (d10
       (lambda (x)
         (reverse (cdr (reverse x)))))
     (div
       (lambda (a b r)
         (cond ((null (cdr b))
                (list (n-normalize r) a))
               (t (let ((quot (div10 a (car b) (cons '#0 '#0))))
                    (div (n- a (car quot))
                         (cons (d10 (car b)) (cddr b))
                         (append r (cdr quot)))))))))
    (cond ((n-zero b) (bottom 'divide-by-zero))
          ((n< a b) (list '#0 a))
          (t (div a (eql a b () '#i) '#0)))))

将两个自然数相除, 只返回商或余数.

(n-quotient natural1 natural2) ----> natural
(n-remainder natural1 natural2) ----> natural

(define (n-quotient a b) (car (n-divide a b)))
(define (n-remainder a b) (cadr (n-divide a b)))

测试一个数是偶数还是奇数. Even 基本上是 (n-zero (remainder x '#2)), 但更有效率.

(even natural) ----> natural
(odd natural) ----> natural

(define (even x)
  (and (memq (car (reverse x)) '#02468) :t))
(define (odd x) (eq (even x) :f))

计算 x 的 y 次方.

(n-expt natural1 natural2) ----> natural

(define (n-expt x y)
  (letrec
    ((square
       (lambda (x)
         (n* x x)))
     (n-expt1
       (lambda (y)
         (cond ((n-zero y) '#1)
               ((even y)
                (square (n-expt1 (n-quotient y '#2))))
               (t (n* x (square (n-expt1 (n-quotient y '#2)))))))))
    (n-expt1 (n-natural y))))

计算不大于给定参数平方根的最大自然数. 这个函数使用牛顿法.

(n-sqrt natural) ----> natural

(define (n-sqrt square)
  (letrec
    ((sqr
       (lambda (x last)
         (cond ((equal last x) x)
               ((equal last (n+ x '#1))
                (cond ((n> (n* x x) square) (n- x '#1))
                      (t x)))
               (t (sqr (n-quotient (n+ x (n-quotient square x))
                                  '#2)
                       x))))))
    (sqr square '#0)))

计算列表的长度. 这个函数在 nmath 包中, 而不在 base 中, 因为它使用数字, 这在本文件中不是一个微不足道的概念, 正如你所看到的.

(length list) ----> natural

(define (length x)
  (letrec
    ((len (lambda (x r)
            (cond ((null x) r)
                  (t (len (cdr x) (n+ r '#1)))))))
    (len x '#0)))

计算两个自然数的最大公约数和最小公倍数.

(n-gcd natural) ----> natural
(n-lcm natural) ----> natural

(define (n-gcd a b)
  (cond ((n-zero b) a)
        ((n-zero a) b)
        ((n< a b) (n-gcd a (n-remainder b a)))
        (t (n-gcd b (n-remainder a b)))))
(define (n-lcm a b)
  (let ((cd (n-gcd a b)))
    (n* cd (n* (n-quotient a cd)
               (n-quotient b cd)))))

查找一个数字列表 L 的极限 k, 使得对于 L 的每个成员 x, k op x 都成立 (如果 op 施加严格的顺序, 则不包括 k). Op 必须是一个在 L 上施加顺序的数值谓词. 当 op = < 时, 例如, limit 返回列表的最小值.

(limit function natural1 natural2 ...) ----> natural

(define (limit op a . b)
  (letrec
    ((lim (lambda (a)
            (cond ((null (cdr a)) (car a))
                  ((op (car a) (cadr a))
                   (lim (cons (car a) (cddr a))))
                  (t (lim (cdr a)))))))
    (lim (cons a b))))

使用 limit 函数查找列表的最大值和最小值.

(max list) ----> natural
(min list) ----> natural

(define (n-max . a) (apply limit n> a))
(define (n-min . a) (apply limit n< a))

(require 'iter)

以下定义指定了自然数运算的首选名称. 例如, 在用户级代码中应该使用 * 而不是 n*, 因为它更具可读性, 更灵活 (因为它是可变参数的), 并且不依赖于特定的数学包.

来自 iter 包的迭代器函数用于使一些二元 nmath 函数变为可变参数. 只有 - 函数是手动转换的, 因为自然数“减”运算符在少于 2 个参数时没有任何意义.

(define natural n-natural)
(define * (arithmetic-iterator n-natural n* '#1))
(define + (arithmetic-iterator n-natural n+ '#0))
(define (- . x)
  (cond ((or (null x) (null (cdr x)))
         (bottom '(too few arguments to n-natural -)))
        (t (fold (lambda (a b)
                   (n- (n-natural a) (n-natural b)))
                 (car x)
                 (cdr x)))))
(define < (predicate-iterator natural n<))
(define <= (predicate-iterator natural n<=))
(define = (predicate-iterator natural n=))
(define > (predicate-iterator natural n>))
(define >= (predicate-iterator natural n>=))
(define divide n-divide)
(define expt n-expt)
(define gcd (arithmetic-iterator natural n-gcd '#0))
(define lcm (arithmetic-iterator natural n-lcm '#1))
(define max n-max)
(define min n-min)
(define number-p natural-p)
(define one n-one)
(define quotient n-quotient)
(define remainder n-remainder)
(define sqrt n-sqrt)
(define zero n-zero)

²²

Zenlisp 源代码必须有 .l 后缀, 否则解释器无法加载它.

(require '~nmath)
(define (hanoi n)
  (letrec
    ((h (lambda (n from to via)
          (cond ((zero n) ())
                (t (append (h (- n '#1) from via to)
                           (list (liat from to))
                           (h (- n '#1) via to from))))))))
    (h n 'from 'to 'via)))

测试该程序最实际的方法是保持一个运行 zenlisp 进程的窗口或虚拟终端打开. 保存上述程序后, 转到 zenlisp 终端并加载程序 (用户输入为斜体):

(load hanoi)
 * hanoi.l: 10: REPL: wrong argument count: (define (hanoi n) (letrec ((h
(lambda (n from to via) (cond ((zero n) ()) (t (append (h (- n '#1) from
via to) (list (liat from to)) (h (- n '#1) via to from)))))))) (h n 'from
'to 'via))

解释器在加载时已经检测到一些语法错误, 比如上面的那个. 它告诉你文件 hanoi.l 的第 10 行包含一个参数数量错误的函数应用. 错误发生在顶层 (REPL).

此时, 一个可以高亮或以其他方式匹配括号的编辑器非常有帮助. 使用它, 你会很快发现文件的 letrec 形式在以下一行中过早结束:

(h (- n '#1) via to from))))))))

删除多余的右括号应该可以解决问题, 事实上, 当你在解释器窗口中重新加载程序时, 它工作得很好 (到目前为止):

(load hanoi)
=> :t

下一步是向程序提供一些输入:

(hanoi '#3)
 * 4: h: symbol not bound: liat
 * Trace: h h

解释器打印的以星号开头的每一行都表示有问题. 在上面的情况下, 它是由一个名为 liat 的未绑定符号引起的. 在这种情况下, 行号是无用的, 因为它指的是 REPL 而不是文件. 然而, 我们可以看到错误发生在 h 函数中. 事实上, 这个函数包含一个拼写错误的 list 实例, 所以这个错误只是一个简单的拼写错误. 只需返回到编辑器会话并修复这个错误:

(list (list from to))

然后回到解释器并再次加载代码. 这次, 它应该可以正常工作:

(load hanoi)
=> :t
(hanoi '#3)
=> '((from to) (from via) (to via) (from to) (via from) (via to) (from to))

太好了. 顺便说一句: 这个程序是第 162 页所示的汉诺塔 MEXPR 程序的原生 zenlisp 版本. 现在让我们尝试一些更有雄心的东西:

(hanoi '#20)

也许, 这有点太雄心勃勃了, 但按 Control 和 c 会停止程序:

^C
 * hanoi.l: 6: append2: interrupted
 * Trace: fold2 h h h h h h h h h

再用一个较小的值试一次:

(hanoi '#14)
=> ...lots of output...

如果你只是想知道需要多少步, 无需重新运行程序. Zenlisp 总是在 REPL 上打印后将最新的结果绑定到变量 ** 上, 所以你只需输入:

(length **)
=> '#16383

如果你想知道为什么 hanoi 函数这么慢, 试试这个:

(gc)
=> '(#76285 #63103)

第一个数字是未使用的“节点”数, 第二个是已使用的“节点”数. 节点是 zenlisp 用来分配内存的抽象单元. 当已使用的节点数大于空闲节点数 (或接近该数) 时, 解释器将开始花费大量时间来回收未使用的内存. 使用更大的内存池运行解释器将给程序带来性能提升:

(quit)
% zenlisp -b 1024K
zenlisp 2008-02-02 by Nils M Holm
(load hanoi)
(hanoi '#14)
=> ...lots of output...
(gc)
=> '(#993789 #63098)

hyper notation	equivalent form
\(a^{(0)}b\)	(s a) for any value of b
\(a^{(1)}b\)	a + b
\(a^{(2)}b\)	a * b
\(a^{(3)}b\)	\(a^b\)
\(a^{(4)}b\)	\(a^{\hat{\,}\hat{\,}}b\)

formula	name
\(O(c)\)	constant
\(O(c \times \log(n))\)	logarithmic
\(O(c \times n)\)	linear
\(O(c \times n^2)\)	quadratic
\(O(n^c)\)	polynomial or geometric
\(O(c^n)\)	exponential

禅意风格编程(zen-style programming)

Table of Contents

1. 第一部分 符号式编程

1.1. 1. 基本方面

1.1.1. 1.1 符号和变量

1.1.2. 1.2 函数

1.1.3. 1.3 条件

1.1.4. 1.4 递归

1.1.5. 1.5 形式和表达式

1.1.6. 1.6 列表递归

1.2. 2. 更有趣的方面

1.2.1. 2.1 可变参数函数

1.2.2. 2.2 相等性与同一性

1.2.3. 2.3 更多控制结构

1.2.4. 2.4 结构递归

1.2.5. 2.5 函数再探

1.2.6. 2.6 局部上下文

1.2.7. 2.7 高阶函数

1.3. 3. 更深奥的方面

1.3.1. 3.1 数值函数

1.3.2. 3.2 副作用

1.3.3. 3.3 元编程

1.3.4. 3.4 包

2. 第二部分 算法

2.1. 4. list 函数

2.1.1. 4.1 heads and tails

2.1.2. 4.2 找到列表的第 n 个尾部

2.1.3. 4.3 计算一个形式中的原子数量

2.1.4. 4.4 扁平化一棵树

2.1.5. 4.5 分割列表

2.1.6. 4.6 在多个列表上折叠

2.1.7. 4.7 替换变量

2.2. 5. 排序

2.2.1. 5.1 插入排序

2.2.2. 5.2 快速排序

2.2.3. 5.3 归并排序

2.2.4. 5.4 打乱列表

2.3. 6. 逻辑与组合函数

2.3.1. 6.1 将列表转换为集合

2.3.2. 6.2 集合的并集与交集

2.3.3. 6.3 查找具有给定属性的成员

2.3.4. 6.4 验证属性

2.3.5. 6.5 集合的组合

2.3.6. 6.6 集合的排列

2.4. 7. 数学函数

2.4.1. 7.1 数字序列

2.4.2. 7.2 快速阶乘函数

2.4.3. 7.3 整数分解

2.4.4. 7.4 整数分区

2.4.5. 7.5 探索可计算性的极限

2.4.6. 7.6 矩阵转置

2.5. 8. 数据结构

2.5.1. 8.1 生成器

2.5.2. 8.2 流

2.5.3. 8.3 ml 风格的记录

2.6. 9. 编译器

2.6.1. 9.1 中缀到前缀的翻译

2.6.2. 9.2 前缀到中缀的翻译

2.6.3. 9.3 正则表达式

2.6.4. 9.4 元循环解释

2.7. 10. mexprc – 一个 m-表达式编译器

2.7.1. 10.1 规范

2.7.2. 10.2 实现

2.7.3. 10.3 示例程序

2.8. 11. 另一个 micro kanren

2.8.1. 11.1 介绍

2.8.2. 11.2 一个逻辑谜题

2.8.3. 11.3 实现

3. 第三部分 zenlisp 实现

3.1. 12. c 部分

3.1.1. 12.1 前奏和数据声明

3.1.2. 12.2 杂项函数

3.1.3. 12.3 错误报告

3.1.4. 12.4 计数函数

3.1.5. 12.5 内存管理

3.1.6. 12.6 符号表

3.1.7. 12.7 读取器

3.1.8. 12.8 原始操作处理程序

3.1.9. 12.9 特殊形式处理程序

3.1.10. 12.10 求值器

1. 第一部分符号式编程

2. 第二部分算法