优秀的Lisp编程风格教程：第四章（译文）

原文链接：https://norvig.com/luv-slides.ps

4. 抽象

所有编程语言都允许开发者来定义抽象。所有现代语言都提供下列支持：

• 数据抽象（抽象数据类型）
• 函数抽象（函数、过程）

Lisp和其他带有闭包的语言（比如：ML, Sather）支持：

• 控制流抽象（定义迭代器和其他控制流结构）

Lisp在下面支持上是独一无二的：

• 语法抽象（宏，全新语言）

设计：风格开始的地方

“编写一个程序最重要的部分是设计数据结构，第二种要的部分是分解各种代码块” – Bill Gates

“专业的工程师对复杂的设计进行分层。 …在每一层构造的部分在下一层用作原语。分层设计的每一层都可以被看作是一种专门的语言，它具有适合于该细节层的各种原语和组合方法。”-- Harold Abelson 和 Gerald Sussman

“尽可能地分解决策。理清那些看似独立的方面。尽可能推迟那些涉及表达细节的决定。”-- Niklaus Wirth

Lisp 支持下面所有方法：

• 数据抽象：类、结构体、deftype
• 函数抽象：函数、方法
• 接口抽象：包、闭包
• 面向对象：CLOS、闭包
• 分层设计：闭包、上面所有
• 延迟决策：运行时分派

设计：分解

“一个Lisp过程就像一个段落” – Deborah Tatar

“你应该能用一句话解释任何模块” – Wayne Ratliff

• 争取简单的设计
• 把问题分成几个部分
  设计有用的子部分（分层）
  投机的；使用现有工具
• 确定依赖关系
  重新模块化以减少依赖
  首先设计最依赖的部分

我们将介绍以下几种抽象：

• 数据抽象
• 函数抽象
• 控制流抽象
• 语法抽象

4.1 数据抽象

根据问题的数据类型编写代码，而不是根据实现中的数据类型编写代码。

• 对记录类型使用defstruct或defclass
• 使用内联函数作为别名（不是宏）
• 使用deftype
• 为了效率和/或文档，使用声明和:type槽
• 变量名提供非正式的类型信息

非常好：指定一些类型信息

(defclass event ()
  ((starting-time :type integer)
   (location :type location)
   (duration :type integer :initform 0)))

更好：问题特定的类型信息

(deftype time () "Time in seconds" 'integer)

(defconstant +the-dawn-of-time+ 0
  "Midnight, January 1, 1900")

(defclass event ()
  ((starting-time :type time :initform +the-dawn-of-time+)
   (location :type location)
   (duration :type time :initform 0)))

使用抽象数据类型

引入带有访问器的抽象数据类型

坏的：模糊的访问器，还有 eval

(if (eval (cadar rules)) ...)

更好的：为访问器引入名称

(declaim (inline rule-antecedent))
(defun rule-antecedent (rule) (second rule))

(if (holds? (rule-antecedent (first rules))) ...)

通常最好：引入一等数据类型

(defstruct rule
  name antecedent consequent)

或

(defstruct (rule (:type list))
  name antecedent consequent)

或

(defclass rule ()
  (name antecedent consequent))

实现抽象数据类型

了解如何从常见的抽象数据类型映射到Lisp实现。

• 集合：list，bit-vector，整数，任何表类型
• 序列：list，vector，延时求值的stream
• 栈：list，vector（带有填充指针的）
• 队列：tconc，vector（带有填充指针的）
• 表：hash表，alist，plist，vector
• 树，图：cons，结构体，vector，邻接矩阵

使用已经支持的实现（例如，union，intersection，length 对于列表集合； logior，logand，logcount 对于整数集合）

如果分析揭示了瓶颈，不要害怕构建新的实现。（如果Common Lisp的哈希表对你的应用来说太低效，在你用C构建一个专门的哈希表之前考虑用Lisp构建一个专门的哈希表）

从数据类型继承

通过继承来重用以及直接使用

• 结构体支持单继承
• 类支持多继承
• 它们都支持重写
• 类支持混入（mixin）

考虑一个类或结构体用于整个程序

• 消除了全局变量的混乱
• 线程安全
• 可以被继承和修改

4.2 函数抽象

每一个函数都应该具有：

• 一个独立且具体的目的
• 如果可能的话，一个普遍有用的目的
• 一个有意义的名称（像recurse-aux这样的名称表明存在问题）
• 一个易于理解的结构
• 一个简单而又足够通用的接口
• 尽可能少的依赖
• 一个文档字符串

分解

将算法分解为简单、有意义和有用的函数。

comp.lang.lisp 的示例讨论了loop和map的对比。

(defun least-common-superclass (instances)
  (let ((candidates
         (reduce #'intersection
                (mapcar #'(lambda (instance)
                            (clos:class-precedence-list
                             (class-of instance)))
                        instances)))
        (best-candidate (find-class t)))
    (mapl
     #'(lambda (candidates)
         (let ((current-candidate (first candidates))
               (remaining-candidates (rest candidates)))
           (when (and (subtypep current-candidate
                                best-candidate)
                      (every
                       #'(lambda (remaining-candidate)
                           (subtypep current-candidate
                                     remaining-candidate))
                       remaining-candidates))
             (setf best-candidate current-candidate))))
     candidates)
    best-candidate))

非常好的：Chris Riesbeck

(defun least-common-superclass (instances)
  (reduce #'more-specific-class
          (common-superclasses instances)
          :initial-value (find-class 't)))

(defun common-superclasses (instances)
  (reduce #'intersection
          (superclass-lists instances)))

(defun superclass-lists (instances)
  (loop for instance in instances
        collect (clos:class-precedence-list
                 (class-of instance))))

(defun more-specific-class (class1 class2)
  (if (subtypep class2 class1) class2 class1))

• 每个功能都很容易理解
• 控制结构清晰：两个reduce，一个相交和一个loop/collect
• 但是可重用性相当低

同样好的：更多的可重用性

(defun least-common-superclass (instances)
  "Find a least class that all instances belong to."
  (least-upper-bound (mapcar #'class-of instances)
                     #'clos:class-precedence-list
                     #'subtypep))

(defun least-upper-bound (elements supers sub?)
  "Element of lattice that is a super of all elements."
  (reduce #'(lambda (x y)
              (binary-least-upper-bound x y supers sub?))
          elements))

(defun binary-least-upper-bound (x y supers sub?)
  "Least upper bound of two elements."
  (reduce-if sub? (intersection (funcall supers x)
                                (funcall supers y))))

(defun reduce-if (pred sequence)
  "E.g. (reduce-if #'> numbers) computes maximum"
  (reduce #'(lambda (x y) (if (funcall pred x y) x y))
          sequence))

• 单个函数仍然可以理解
• 仍然是两个reduce，一个相交和一个mapcar
• 分层设计产生更多有用的功能

英语翻译的原则

确保你说的是你想说的：

1. 以算法的英语描述开始
2. 根据描述编写代码
3. 把代码翻译回英语
4. 比较第3点和第1点的结果

示例：

1. “Given a list of monsters, determine the number that are swarms.”

(defun count-swarm (monster-list)
  (apply '+
         (mapcar
          #'(lambda (monster)
              (if (equal (object-type
                          (get-object monster))
                         'swarm)
                  1
                  0))
          monster-list)))

3. “Take the list of monsters and produce a 1 for a monster whose type is swarm, and a 0 for the others. Then add up the list of numbers.”

更好的：

1. “Given a list of monsters, determine the number that are swarms.”

(defun count-swarms (monster-names)
  "Count the swarms in a list of monster names."
  (count-if #'swarm-p monster-names :key #'get-object))

或

(count 'swarm monster-names :key #'get-object-type)

或

(loop for name in monster-names
      count (swarm-p (get-object monster)))

3. “Given a list of monster names, count the number
   that are swarms.”

使用库函数

库函数可以访问低级别的高效hack，并且经常进行新的调优。

但它们可能过于笼统，因此效率低下。

当效率成为一个问题时，在编写具体版本。

好的：具体的，简洁的

(defun find-character (char string)
  "See if the character appears in the string."
  (find char string))

好的：高效的

(defun find-character (char string)
  "See if the character appears in the string."
  (declare (character char) (simple-string string))
  (loop for ch across string
        when (eql ch char) return ch))

给定一个build1，它将n映射为一个n个x的列表：
(build1 4)) -> (x x x x)

任务：定义build-it使得：

(build-it '(4 0 3))) -> ((x x x x) () (x x x))

非常糟糕的：

(defun round3 (x)
  (let ((result '()))
    (dotimes (n (length x) result)
      (setq result (cons (car (nthcdr n x)) result)))))

(defun build-it (arg-list)
  (let ((result '()))
    (dolist (a (round3 arg-list) result)
      (setq result (cons (build1 a) result)))))

问题：

• round3只是reverse的另一个名字
• (car (nthcdr n x)) 就是 (nth n x)
• 在这里dolist比dotimes更好
• 在这里push是合适的
• (mapcar #'build1 numbers) 可以全做了

控制结构抽象

大多数算法可以被描述为：

• 搜索（some find find-if mismatch）
• 排序（sort merge remove-duplicates）
• 过滤（remove remove-if mapcan）
• 映射（map mapcar mapc）
• 比较（reduce mapcan）
• 计数（count count-if）

这些函数抽象了常见的控制模式。使用它们的代码是：

• 简洁的
• 自文档描述
• 易于理解
• 通常可重用
• 通常是高效的（比一个非尾递归更好）

引入自己的控制抽象是分层设计的重要组成部分。

递归 vs 迭代

递归对于递归数据结构是有益的。许多人更喜欢将列表视为一个序列，并对其使用迭代，从而忽略了列表被分割为头部和剩余部分的实现细节。

作为一种表达风格，尾递归通常被认为是优雅的。然而，Common Lisp并不保证尾部递归的消除，因此在完全可移植的代码中，它不应该被用作迭代的替代品。(Scheme中是没问题的。)

Common Lisp do宏可以被认为是尾部递归的语法糖，其中变量的初始值是第一次函数调用的参数值，步长值是后续函数调用的参数值。

do提供了一个低层次的抽象，但是通用，并且有一个简单、显式的执行模型。

坏的：（在Common Lisp中）

(defun any (lst)
  (cond ((null lst) nil)
        ((car lst) t)
        (t (any (cdr lst)))))

更好的：习惯的，简洁的

(defun any (list)
  "Return true if any member of list is true."
  (some #'not-null list))

或者

(find-if-not #'null lst)

或者

(loop for x in list thereis x)

或者（明确的）

(do ((list list (rest list)))
    ((null list) nil)
  (when (first list))
    (return t))

最好的：高效，这个例子中最简洁

不要调用any！

使用(some p list)而不是(any (mapcar p list))

LOOP

“Keep a loop to one topic|like a letter to your Senator.” – Judy Anderson

Common Lisp的loop宏使您能够简洁地表达习惯用法。然而，它的语法和语义往往比它的替代品要复杂得多。

是否使用loop宏是一个有争议的问题，几乎是一场宗教战争。这种冲突的根源是以下这个有点自相矛盾的观察：

• loop对幼稚的程序员很有吸引力，因为它看起来像英语，似乎比它的替代品需要更少的编程知识。
• loop不是英语；它的语法和语义具有微妙的复杂性，这是许多编程错误的根源。它通常最适合那些花时间研究和理解它的人使用（通常不是幼稚的程序员）。

利用loop的独特功能（比如，不同类型的并行迭代）

简单迭代

坏的：冗长，控制结构不清晰

(LOOP
  (SETQ *WORD* (POP *SENTENCE*))  ;get the next word
  (COND
   ;; if no more words then return instantiated CD form
   ;; which is stored in the variable *CONCEPT*
   ((NULL *WORD*)
    (RETURN (REMOVE-VARIABLES (VAR-VALUE '*CONCEPT*))))
   (T (FORMAT T "~%~%Processing ~A" *WORD*)
      (LOAD-DEF)   ; look up requests under
                   ; this word
      (RUN-STACK)))) ; fire requests

• 不需要全局变量
• 结束测试具有误导性
• 现在还不清楚对每个单词做了什么

好的：习惯的，简洁的，明确的

(mapc #'process-word sentence)
(remove-variables (var-value '*concept*))

(defun process-word (word)
  (format t "~2%Processing ~A" word)
  (load-def word)
  (run-stack))

映射

坏的：冗长的

; (extract-id-list 'l_user-recs) ------------- [lambda]
; WHERE: l_user-recs is a list of user records
; RETURNS: a list of all user id's in l_user-recs
; USES: extract-id
; USED BY: process-users, sort-users

(defun extract-id-list (user-recs)
  (prog (id-list)
  loop
    (cond ((null user-recs)
           ;; id-list was constructed in reverse order
           ;; using cons, so it must be reversed now:
           (return (nreverse id-list))))
    (setq id-list (cons (extract-id (car user-recs))
                        id-list))
    (setq user-recs (cdr user-recs)) ;next user record
    (go loop)))

好的：习惯的，简洁的

(defun extract-id-list (user-record-list)
  "Return the user ID's for a list of users."
  (mapcar #'extract-id user-record-list))

计数

坏的：冗长的

(defun size ()
  (prog (size idx)
    (setq size 0 idx 0)
   loop
     (cond ((< idx table-size)
            (setq size (+ size (length (aref table idx)))
                  idx (1+ idx))
            (go loop)))
     (return size)))

好的：习惯的，简洁的

(defun table-count (table) ; Formerly called SIZE
  "Count the number of keys in a hash-like table."
  (reduce #'+ table :key #'length))

此外，补充一点也无妨：

(deftype table ()
  "A table is a vector of buckets, where each bucket
  holds an alist of (key . values) pairs."
  '(vector cons))

过滤

坏的：冗长的

(defun remove-bad-pred-visited (l badpred closed)
  ;;; Returns a list of nodes in L that are not bad
  ;;; and are not in the CLOSED list.
  (cond ((null l) l)
        ((or (funcall badpred (car l))
             (member (car l) closed))
         (remove-bad-pred-visited
          (cdr l) badpred closed))
        (t (cons (car l)
                 (remove-bad-pred-visited
                  (cdr l) badpred closed)))))

好的：习惯的，简洁的

(defun remove-bad-or-closed-nodes (nodes bad-node? closed)
  "Remove nodes that are bad or are on closed list"
  (remove-if #'(lambda (node)
                 (or (funcall bad-node? node)
                     (member node closed)))
             nodes))

控制流：保持简单

非局部控制现在很难理解

坏的：冗长的，违反了引用透明性

(defun isa-test (x y n)
  (catch 'isa (isa-test1 x y n)))

(defun isa-test1 (x y n)
  (cond ((eq x y) t)
        ((member y (get x 'isa)) (throw 'isa t))
        ((zerop n) nil)
        (t (any (mapcar
                #'(lambda (xx)
                    (isa-test xx y (1- n)) )
                (get x 'isa) ))) ) )

问题：

• catch/throw是无理由的
• member测试可能有帮助，也可能没有帮助
• mapcar产生垃圾
• any测试太晚；throw尝试去修复这个结果使得any永远得不到调用

关于catch和throw使用的一些建议：

• 当以宏的形式实现更抽象的控制结构时，使用catch和throw作为子基元，但不要在普通代码中使用它们。
• 有时，当您建立捕获时，程序可能需要测试它的存在。在这种情况下，重启可能更合适。

好的：

(defun isa-test (sub super max-depth)
  "Test if SUB is linked to SUPER by a chain of ISA
  links shorter than max-depth."
  (and (>= max-depth 0)
       (or (eq sub super)
           (some #'(lambda (parent)
                     (isa-test parent super
                               (- max-depth 1)))
                 (get sub 'isa)))))

也是好的：使用工具

(defun isa-test (sub super max-depth)
  (depth-first-search :start sub :goal (is super)
                      :successors #'get-isa
                      :max-depth max-depth))

“Write clearly|don’t be too clever.” – Kernighan & Plauger

意识到：

“改进”某物会改变语义吗？这有关系吗？

避免复杂的Lambda表达式

当高阶函数需要复杂的lambda表达式时，请考虑其他选择：

• dolist或loop
• 生成中间(垃圾)序列
• Series
• 宏或读取宏
• 局部函数

– 具体的：明确函数在哪里使用
– 不会弄乱全局名称空间
– 局部变量不需要是参数
– 但是：有些调试工具不起作用

求一串整数中奇数的平方和：

一切都好：

(reduce #'+ numbers
        :key #'(lambda (x) (if (oddp x) (* x x) 0)))

(flet ((square-odd (x) (if (oddp x) (* x x) 0)))
  (reduce #'+ numbers :key #'square-odd))

(loop for x in list
      when (oddp x) sum (* x x))

(collect-sum (choose-if #'oddp numbers))

还要考虑：（有时可能是合适的）

;; Introduce read macro:
(reduce #'+ numbers :key #L(if (oddp _) (* _ _) 0))

;; Generate intermediate garbage:
(reduce #'+ (remove #'evenp (mapcar #'square numbers)))

函数式风格 vs 命令式风格

有人认为命令式风格的程序更难推理。下面是一个源于命令式方法的bug：

任务：编写一个内置函数find的版本。

坏的：不正确

(defun i-find (item seq &key (test #'eql) (test-not nil)
               (start 0 s-flag) (end nil)
               (key #'identity) (from-end nil))
  (if s-flag (setq seq (subseq seq start)))
  (if end (setq seq (subseq seq 0 end)))
  ...)

问题：

• 获取子序列会产生垃圾
• 不表示列表/向量的差异
• 如果同时给出start和end，则会出现错误，错误源于seq的更新

示例：简化

任务：逻辑表达式的简化器

(simp '(and (and a b) (and (or c (or d e)) f)))
-> (AND A B (OR C D E) F)

不错，但不完美：

(defun simp (pred)
  (cond ((atom pred) pred)
        ((eq (car pred) 'and)
         (cons 'and (simp-aux 'and (cdr pred))))
        ((eq (car pred) 'or)
         (cons 'or (simp-aux 'or (cdr pred))))
        (t pred)))

(defun simp-aux (op preds)
  (cond ((null preds) nil)
        ((and (listp (car preds))
              (eq (caar preds) op))
         (append (simp-aux op (cdar preds))
                 (simp-aux op (cdr preds))))
        (t (cons (simp (car preds))
                 (simp-aux op (cdr preds))))))

问题：

• 无意义的名字simp-aux
• 没有可重用的部分
• 无数据访问器
• (and)和(and a)没有被简化

更好的：可用的工具

(defun simp-bool (exp)
  "Simplify a boolean (and/or) expression."
  (cond ((atom exp) exp)
        ((member (op exp) '(and or))
         (maybe-add (op exp)
                    (collect-args
                     (op exp)
                     (mapcar #'simp-bool (args exp)))))
        (t exp)))

(defun collect-args (op args)
  "Return the list of args, splicing in args
  that have the given operator, op. Useful for
  simplifying exps with associate operators."
  (loop for arg in args
        when (starts-with arg op)
        nconc (collect-args op (args arg))
        else collect arg))

构建可重用的工具

(defun starts-with (list element)
  "Is this a list that starts with the given element?"
  (and (consp list)
       (eql (first list) element)))

(defun maybe-add (op args &optional
                     (default (get-identity op)))
  "If 1 arg, return it; if 0, return the default.
  If there is more than 1 arg, cons op on them.
  Example: (maybe-add 'progn '((f x))) ==> (f x)
  Example: (maybe-add '* '(3 4)) ==> (* 3 4).
  Example: (maybe-add '+ '()) ==> 0,
  assuming 0 is defined as the identity for +."
  (cond ((null args) default)
        ((length=1 args) (first args))
        (t (cons op args))))

(deftable identity
  :init '((+ 0) (* 1) (and t) (or nil) (progn nil)))

4.4 语法抽象（Syntactic abstraction）

一种简化的语言

任务：一个用于以下所有表达式的简化器：

(simplify '(* 1 (+ x (- y y)))) ==> x
(simplify '(if (= 0 1) (f x))) ==> nil
(simplify '(and a (and (and) b))) ==> (and a b)

语法抽象定义一个适合该问题的新语言。

这是一种面向问题（相对于面向代码而言）的方法。

定义一种简化规则的语言，然后编写：

(define-simplifier exp-simplifier
  ((+ x 0) ==> x)
  ((+ 0 x) ==> x)
  ((- x 0) ==> x)
  ((- x x) ==> 0)
  ((if t x y) ==> x)
  ((if nil x y) ==> y)
  ((if x y y) ==> y)
  ((and) ==> t)
  ((and x) ==> x)
  ((and x x) ==> x)
  ((and t x) ==> x)
  ...)

仔细地设计你的语言

“The ability to change notations empowers human beings.” – Scott Kim

坏的：冗长的，脆弱的

(setq times0-rule '(
  simplify
  (* (? e1) 0)
  0
  times0-rule
  ) )

(setq rules (list times0-rule ...))

• 不充分的抽象
• 需要命名times0-rule三次
• 引入不必要的全局变量
• 非常规缩进

有时这样给规则命名是有用的：

(defrule times0-rule
  (* ?x 0) ==> 0)

（虽然在这种情况下我不建议这么做。）

一个用于简化的解释器

现在我们编写一个解释器（或一个编译器）：

(defun simplify (exp)
  "Simplify expression by first simplifying components."
  (if (atom exp)
    exp
    (simplify-exp (mapcar #'simplify exp))))

(defun-memo simplify-exp (exp)
  "Simplify expression using a rule, or math."
  ;; The expression is non-atomic.
  (rule-based-translator exp *simplification-rules*
    :rule-pattern #'first
    :rule-response #'third
    :action #'simplify
    :otherwise #'eval-exp))

这个解决方案比较好，因为：

• 简化规则易于编写
• 控制流被抽象了（大部分）
• 很容易验证规则是否正确
• 该程序可以很快启动并运行

如果这个方法是充分的，我们就完成了。如果这个方法不够，我们节省了时间。如果只是缓慢，我们可以改进这些工具，这些工具的其他用途也会从中受益。

一个用于翻译的解释器

“Success comes from doing the same thing over and over again; each time you learn a little bit and you do a little better the next time.” – Jonathan Sachs

抽象出基于规则的翻译器：

(defun rule-based-translator
  (input rules &key (matcher #'pat-match)
         (rule-pattern #'first) (rule-response #'rest)
         (action #identity) (sub #'sublis)
         (otherwise #'identity))
  "Find the first rule that matches input, and apply the
  action to the result of substituting the match result
  into the rule's response. If no rule matches, apply
  otherwise to the input."
  (loop for rule in rules
    for result = (funcall matcher
                   (funcall rule-pattern rule) input)
    when (not (eq result fail))
    do (RETURN (funcall action
                 (funcall sub result
                   (funcall rule-response rule))))
    finally (RETURN (funcall otherwise input))))

如果这个实现太慢，我们可以更好地索引或编译。

有时，复用是在非正式层面上的：查看如何构建通用工具使得程序员通过剪切和粘贴构建自定义工具。

保存重复工作：defun-memo

比设计一门全新语言更极端的方法是用新的宏来增强Lisp语言。

defun-memo 使一个函数记住它所做的所有计算。它通过维护输入/输出对的哈希表来实现这一点。如果第一个参数只是该函数名，会发生两种情况中的一种：[1]如果只有1个参数，并且它不是&rest参数，它会在该参数上创建一个eql表。[2]否则它在整个参数列表上生成一个equal表。

你也可以把fn-name替换为(name :test ... :size ... :key-exp ...)。这将生成一个带有给定测试和大小的表，并且根据key-exp来索引。可以使用clear-memo函数清除哈希表。

示例：

(defun-memo f (x)              ;; eql table keyed on x
  (complex-computation x))

(defun-memo (f :test #'eq) (x) ;; eq table keyed on x
  (complex-computation x))

(defun-memo g (x y z)          ;; equal table
  (another-computation x y z)) ;; keyed on on (x y . z)

(defun-memo (h :key-exp x) (x &optional debug?)
                               ;; eql table keyed on x
...)

(defmacro defun-memo (fn-name-and-options (&rest args)
                                          &body body)
  ;; Documentation string on previous page
  (let ((vars (arglist-vars args)))
    (flet ((gen-body (fn-name &key (test '#'equal)
                              size key-exp)
             `(eval-when (load eval compile)
               (setf (get ',fn-name 'memoize-table)
                (make-hash-table :test ,test
                 ,@(when size `(:size ,size))))
               (defun ,fn-name ,args
                 (gethash-or-set-default
                  ,key-exp
                  (get ',fn-name 'memoize-table)
                  (progn ,@body))))))
      ;; Body of the macro:
      (cond ((consp fn-name-and-options)
             ;; Use user-supplied keywords, if any
             (apply #'gen-body fn-name-and-options))
            ((and (= (length vars) 1)
                  (not (member '&rest args)))
             ;; Use eql table if it seems reasonable
             (gen-body fn-name-and-options :test '#'eql
                       :key-exp (first vars)))
            (t ; Otherwise use equal table on all args
             (gen-body fn-name-and-options :test '#'equal
                       :key-exp `(list* ,@vars)))))))

更多的宏

(defmacro with-gensyms (symbols body)
  "Replace the given symbols with gensym-ed versions,
  everywhere in body. Useful for macros."
  ;; Does this everywhere, not just for "variables"
  (sublis (mapcar #'(lambda (sym)
                      (cons sym (gensym (string sym))))
                  symbols)
          body))

(defmacro gethash-or-set-default (key table default)
  "Get the value from table, or set it to the default.
  Doesn't evaluate the default unless needed."
  (with-gensyms (keyvar tabvar val found-p)
    `(let ((keyvar ,key)
           (tabvar ,table))
      (multiple-value-bind (val found-p)
          (gethash keyvar tabvar)
        (if found-p
            val
            (setf (gethash keyvar tabvar)
                  ,default))))))

适当使用宏

（参见Allan Wechsler的教程）

宏的设计：

• 决定是否真的需要一个宏
• 为宏选择一种清晰一致的语法
• 求出正确的展开
• 使用defmacro和 ` 来实现映射
• 在大多数情况下，还要提供一个函数式接口（有用的，有时更容易更改和继续）。

需要考虑的事情：

• 如果使用函数就足够了，不要使用宏
• 确保在扩展时什么都不做（大多数情况下）
• 从左到右对参数求值，每个求一次（如果有的话）
• 不要与用户的命名冲突（使用 with-gensyms）

宏的问题

坏的：应该使用内联函数

(defmacro name-part-of (rule)
  `(car ,rule))

坏的：应该是一个函数

(defmacro defpredfun (name evaluation-function)
  `(push (make-predfun :name ,name
          :evaluation-function ,evaluation-function)
         *predicate-functions*))

坏的：在展开的时候起作用

(defmacro defclass (name &rest def)
  (setf (get name 'class) def)
  ...
  (list 'quote name))

坏的：宏不应该对参数求值

(defmacro add-person (name mother father sex
                           unevaluated-age)
  (let ((age (eval unevaluated-age)))
    (list (if (< age 16) ... ...) ...)))

(add-person bob joanne jim male (compute-age 1953))

如果现在编译这个调用并在几年后加载它会怎么样？

更好的：让编译器常量折叠

(declaim (inline compute-age))

(defmacro add-person (name mother father sex age)
  `(funcall (if (< ,age 16) ... ...) ...))

非常差：（如果增量是n呢？）

(defmacro for ((variable start end &optional increment)
               &body body)
  (if (not (numberp increment)) (setf increment 1))
  ...)

(for (i 1 10) ...)

宏用于控制结构

好的：填补CL的正交性中一个空洞

(defmacro dovector ((var vector &key (start 0) end)
                    &body body)
  "Do body with var bound to each element of vector.
  You can specify a subrange of the vector."
  `(block nil
    (map-vector #'(lambda (,var) ,@body)
                ,vector :start start :end end)))

(defun map-vector (fn vector &key (start 0) end)
  "Call fn on each element of vector within a range."
  (loop for i from start below (or end (length vector))
        do (funcall fn (aref vector-var index))))

• 迭代公共数据类型
• 遵循既定语法（dolist，dotimes）
• 服从声明，返回
• 用关键字扩展已建立的语法
• 有一点不好：没有dolist，dotimes那样的结果

宏的帮助函数

大多数宏应该展开为对函数的调用。

宏dovector的真正工作由一个函数map-vector来完成，因为：

• 它更容易修补
• 它是可单独调用的（对程序很有用）
• 生成的代码更小
• 如果愿意，可以将这个帮助函数设置为内联的（通常有利于避免构造闭包）

(dovector (x vect) (print x))

宏展开为：

(block nil
  (map-vector #'(lambda (x) (print x)) vect
              :start 0 :end nil))

它内联展开为（粗略地）：

(loop for i from 0 below (length vect)
        do (print (aref vect i)))

setf 方法

与在宏中一样，我们需要确保按从左到右的顺序对每个表达式形式只求值一次。

确保在正确的环境中执行宏展开（macroexpand、get-setf-method）。

(defmacro deletef (item sequence &rest keys
                        &environment environment)
  "Destructively delete item from sequence."
  (multiple-value-bind (temps vals stores store-form
                              access-form)
      (get-setf-method sequence environment)
    (assert (= (length stores) 1))
    (let ((item-var (gensym "ITEM")))
      `(let* ((,item-var ,item)
              ,@(mapcar #'list temps vals)
              (,(first stores)
               (delete ,item-var ,access-form ,@keys)))
        ,store-form))))