Published: 2018-01-13

阅读 On Lisp

On Lisp 是一本讲解lisp宏使用技巧的书,之前囫囵吞枣翻阅过,最近拿起来从头开始拜读。故在此记录一些学到的知识,本文会随着学习的进度而更新。

Table of Contents

1 symbol-value 和 symbol-function

common lisp is a lisp-2 language, funtion and variable have different name space, 所以一个symbol可以同时是一个function和variable 用 symbol-value 获取变量值 用 symbol-function 获取函数值

;;假设有个double1的symbol:

;;设置该symbol的value
(setq double1 4)
or
(setf (symbol-value 'double1) 5)

;;设置该symbol的function
(setf (symbol-function 'double1) #'(lambda (x) (* x 2)))


;; #'foo 是 (function foo)的缩写
;; 可以理解为将名字映射到实际的函数对象
#'double1 返回的是上面定义的函数对象

;; lambda 表达式可以同时是函数和函数名字
#'(lambda (x) (* x 2)) 返回的也是函数对象



;; 所以 defun 等价于
(defun double1 (x)
    (* x 2))

(setf (symbol-function 'double1)
    (lambda (x) (* x 2)))
or
(setf (symbol-function 'double1)
    #'(lambda (x) (* x 2)))



;; 再来看一个闭包的例子
(defun make-adder (n)
   #'(lambda (x) (+ x n)))

(setf add2 (make-adder 2))

;; 调用add2 的结果
(add2 4)
=>
The function COMMON-LISP-USER::ADDER2 is undefined.
   [Condition of type UNDEFINED-FUNCTION]

Restarts:
 0: [CONTINUE] Retry using ADDER2.
 1: [USE-VALUE] Use specified function
 2: [RETRY] Retry SLIME REPL evaluation request.
 3: [*ABORT] Return to SLIME's top level.
 4: [ABORT] abort thread (#<THREAD "new-repl-thread" RUNNING {10052AAAF3}>)

Backtrace:
  0: (SYMBOL-FUNCTION ADDER2)   <---注意这里
  1: (SB-INT:SIMPLE-EVAL-IN-LEXENV (ADDER2 4) #<NULL-LEXENV>)
  2: (EVAL (ADDER2 4))

;; 因为setf 是设置 symbol add2 的 symbol-value
;; 当(add2 4)这样调用的时候回去找 'add2 的symbol-function, 所以找不到
;; 所以正确的调用方式如下
(funcall add2 4)
or
(funcall (symbol-value 'add2) 4)

2 apply 和 funcall

作用都是对函数求值,区别在于 apply 接受的函数将被作用到一个列表,该列表由余下的参数cons到最后一个产生,所以最后一个参数一定要是一个列表

如果不方便以列表形式提供参数,则使用funcall

(apply #'+ '(1 2))
(apply #'+ 1 '(2))

(funcall #'+ 1 2)

3 模拟面向对象中的"方法"(method)

;; 根据动物不同种类做不同事情
(defun behave (animal)
   (case animal
     (dog (wag-tail)
          (bark))
     (rat (scurry)
          (squeak))
     (cat (rub-legs)
          (scratch-carpet))))

;; 当需要添加一直动物时,就得修改上述代码
;; 为了更好的扩展性,可以如下做
(defun dehave (animal)
   (funcall (get animal 'behavior)))

(setf (get 'dog 'behavior)
    #'(lambda () (wag-tail) (bark))

...

;; 这样类似于面向对象里面的方法

4 尾递归优化

许多common lisp编译器可以把尾递归转化成循环,如果使用这种编译器,可以在源代码里写优雅的递归而不必担心函数调用在运行期产生的系统开销

;; 下列函数不是一个尾递归
(defun our-length (lst)
    (if (null lst)
        0
        (1+ (our-length (cdr lst)))))


;; 通常不是尾递归的函数可以使用一个累积器(accumulator)的局部函数嵌入到其中,从而转化成一个尾递归形式
(defun our-length (lst)
   (labels ((rec (lst acc)
              (if (null lst)
                  acc
                  (rec (cdr lst) (1+ acc)))))
     (rec lst 0)))

;; 通过在调用树从上往下走的过程中累计这个值,而不是从下往上返回的时候再计算

另外许多编译器虽然能做尾递归优化,但这不是所有编译器的默认行为,所以在编写尾递归函数时,应该把 (proclaim '(optimize speed)) 写在文件前面, 以确保编译器进行优化

下面是一个递归->尾递归->迭代的示例:

;;; filter函数的作用是给的一个函数fn,一个列表lst, 将fn作用在lst中的每个元素,如果结果不为nil,则将值收集到一个列表中返回

;; 第一版定义
(defun filter (fn lst)
  (labels ((rec (lst)
             (if (null lst)
                 nil
                 (let ((val (funcall fn (car lst))))
                   (if val
                       (cons val (rec (cdr lst)))
                       (rec (cdr lst)))))))
    (rec lst)))
;; 可以看出该函数采用递归方式,将fn分别作用在(car lst)和(cdr lst)上,再根据结果选择是否cons起来


;; 第二版定义: 尾递归
(defun filter (fn lst)
  (labels ((rec (lst acc)
             (if (null lst)
                 acc
                 (let ((val (funcall fn (car lst))))
                   (if val
                       (rec (cdr lst) (cons val acc))
                       (rec (cdr lst) acc))))))
    (nreverse  (rec lst nil))))
;; 采用内部累积器acc, 将每次结果累积到acc里一直传下去,到达最后直接返回acc


;; 第三版定义: 循环
(defun filter (fn lst)
  (let ((acc nil))
    (dolist (x lst)
      (let ((val (funcall fn x)))
        (if val (push val acc))))
    (nreverse acc)))
;; 此形式类似于上面第二版本尾递归形式的编译器优化版本。将尾递归递归转化成迭代
;; 这里将第二版每次传递的累积器acc剥离到外层,不再传递它,而是每次对它进行修改;
;; 对于列表的聚积操作来说, 上述定义中的push和nrevese组合是标准的lisp用法

5 编译

lisp 函数可以单独编译或者按文件编译。 如果在toplevel下输入一个defun表达式 (defun foo (x) (1+ x)) ,多数实现会创先相应的解释函数(interpreted funtion), 可以使用 (compiled-funtion-p #'foo) 来检查函数是否编译过。

使用 compile 来编译函数,如 (compile 'foo)

使用 compile-file 来编译整个文件

(compile nil '(lambda (x) (+ x 2))) 会编译里面的lambda表达式

(progn (compile 'bar '(lambda (x) (* x 3)))
       (compiled-function-p #'bar))

;; 上面(compile 'bar '(lambda (x) (* x 3))) 相当于便以一个defun bar

;; 当某些小函数调用开销会超出执行开销时,可以内联编译
(defun 50th (lst) (nth 49 lst))
(proclaim '(inline 50th))

;; 这样当编译foo时, 50th代码会被编译到内部
(defun foo (lst)
    (+ (50th lst) 1))

;; 就好像是原来写的就是下面这样
(defun foo (lst)
    (+ (nth 49 lst) 1))

;; 缺点是改动50th的话,要重新编译foo, 否则foo还是用的原来的


6 迷思: 使用一堆新操作符(实用工具/utils)让程序难读懂?

以下摘自原书4.8节

如果你在代码里用了大量实用工具,有的读者可能会抱怨这种程序晦涩难懂。那些还没能自如使用Lisp的人只能习惯阅读原始的Lisp。 事实上,他们可能一直就无法认同可扩展语言的理念。当读到一个严重依赖实用工具的程序时,在他们看来,作者可能是完全出于怪癖而决定用某种私人语言来写 程序。

会有人提出,所有这些新操作符让程序更难读了。他认为必须首先理解所有的这些新操作符,才能读懂程序。 要想知道为什么这类说法是错误的,不妨想想第27页的那个例子,在那里我们想要找到最近的书店。如果用 find2 来写程序,有人可能会抱怨说,在他能够读懂这个程序之前,必须先理解这个实用工具的定义。好吧,假设你没有用 find2 。那么现在可以不用先理解 find2 了,但是读者将不得不去理解 find-books 的定义,该函数相当于把 find2 和查找书店的特定任务混在了一起。理解 find2 并不比理解 find-books 更难。另一方面,在这里我们只用了一次这个新的实用工具。实用工具意味着重复使用。在实际的程序里,它意味着在下列两种情况中做出选择,理解 find2,或者不得不去理解三到四种特定的搜索例程。显然前者更容易些。

所以,阅读自底向上的程序确实需要理解作者定义的所有新操作符。但它的工作量几乎总是比理解在没有这些操作符的情况下的所有代码要少很多。

如果人们抱怨说使用实用工具使得你的代码难于阅读了,他们很可能根本没有意识到,如果你不使用这些实用工具的话代码看起来将是什么样子。自底向上程序设计让本来规模很大的程序看起来短小简单。给人的感觉就是,这程序并没有做很多事,所以应该很好懂。当缺乏经验的读者们更仔细地阅读程序,结果发现事情并没有想象的那么简单,他们就会灰心丧气。

我们在其他领域观察到了相同的现象:设计合理的机器可能部件数量更少,但是看起来会感觉更复杂,因为这些部件被安置在了更小的空间里。自底向上的程序有种感官上的紧密性。阅读这种程序 可能需要花一些力气,但如果不是这样写的话,你会需要花更多的精力来读懂它们。

有一种情况下,你应该有意地避免使用实用工具,即:如果你需要写一个小程序,它将独立于其余部分的代码发布。一个实用工具通常至少要被使用两到三次才值得引入,但在小程序里如果一个实用工具用得太少的话,可能就没有必要包含它了。

7 语言正交性

正交的语言让我们只需运用多种方式对数量有限的操作符加以组合,就能获得强大的表达能力。玩具积木是非常正交的,而套装塑料模型就很难说他是正交的。

common lisp 有一个函数 complement, 作用是接受一个谓词 p 作为参数,返回一个函数 p1 , 同样的参数情况下,这个 p1 的返回值总和 p 得到相反:

(defun complement (fn)
  #'(lambda (&rest args) (not (apply fn args))))

这样common lisp提供的几组互补的函数就可以用 complement 配合一个得到另一个,比如:

(remove-if-not #'pred lst)

(remove-if (complement #'pred) lst)

;; 这样就没有必要有remove-if-not(虽然remove-if-not 会比 remove-if 更常用))

同样 setf 宏也增强Lisp的正交性,Lisp早期的方言会用成对的函数分别实现读数据和写数据,在common lisp里,只有读数据,写数据使用 setf 配合读数据实现的:

;; 获取ball的color
(get 'ball 'color)

;;设置ball的color
(setf (get 'ball 'color) 'red)


;; 获取hash中key对应的值
(gethash key hash-table)

;; 设置key对应的值
(setf (gethash key hash-table) 'some-value)

还有种成对方式出现的函数:函数和它的破坏性版本,比如: remove-ifdelete-if, reversenreverse, appendnconc 。我们或许不能让common lisp变得更精简,但可以定义一些新操作符,像 complementsetf 那样达到差不多效果:

;; 存储fn和它的破坏性版本fn!
(defvar *!equivs* (make-hash-table))

;; 获取fn对应的破坏性版本fn!
(defun ! (fn)
  (or (gethash fn *!equivs*) fn))

;; 设置fn对应的破坏性版本fn!
(defun def! (fn fn!)
  (setf (gethash fn *!equivs*) fn!))

这样,一旦定义了:

(def! #'remove-if #'delete-if)

就可以把:

(delete-if #'oddp lst)

改写成:

(funcall (! #'remove-if) #'oddp lst)

;; 虽然上面的代码在common lisp有些尴尬,它模糊了这个思路的良好初衷,要是用Scheme就会明了很多
((! remove-if) oddo lst)
;; 可以通过 ! 一眼看出来现在调用的是remove-if的破坏性版本

另外由于函数及其对应破坏性版本的取舍经常在运行期之前就能确定,所以把 ! 定义成宏或许是更高效的选择。

8 缓存函数和复合函数(函数as参数和返回值)

缓存函数 memoize:

(defun memoize (fn)
   (let ((cache (make-hash-table :test #'equal)))
     #'(lambda (&rest args)
         (multiple-value-bind (val win) (gethash fn cache)
           (if win
               val
               (setf (gethash fn cache)
                     (apply fn args)))))))

;; 局限:
;; 1.参数列表是equal的调用才是等同,对于有些关键字参数函数过于严格
;; 2.对于返回单值的函数才有效(无法保存和返回多值)

单纯复合函数 compose :

;; 定义
(defun compose (&rest fns)
   (if fns
       (let ((fn1 (car (last fns)))
             (fns (butlast fns)))
         #'(lambda (&rest args)
             (reduce #'funcall fns
                     :from-end t
                     :initial-value (apply fn1 args))))
       #'identity))

;; 使用
CL-USER> (funcall (compose #'1+ #'find-if) #'oddp '(2 3 4 5))
4

;; (compose #'list #'1+)
;;  等价于 #'(lambda (x) (list (1+ x)))


复合函数 fif fint fun :

(defun fif (if then &optional else)
   #'(lambda (x)
       (if (funcall if x)
           (funcall then x)
           (if else (funcall else x)))))

;; fint means "function intersection"(函数交集)
(defun fint (fn &rest fns)
    (if (null fns)
       fn
       (let ((chain (apply #'fint fns)))
         #'(lambda (x)
             (and (funcall fn x) (funcall chain x))))))

;; fun means "function union"(函数并集)
(defun fun (fn &rest fns)
   (if (null fns)
       fn
       (let ((chain (apply #'fun fns)))
         #'(lambda (x)
             (or (funcall fn x) (funcall chain x))))))


这样的话:

;; 1.这种常见的模式:
(mapcar #'(lambda (x)
            (if (slave x)
                (owner x)
                (employer x)))
        people)

;; 可以写成:
(mapcar (fif #'slave #'owner #'employer) people)



;; 2.这种常见的模式:
(find-if #'(lambda (x)
             (and (signed x) (sealed x) (delivered x)))
         docs)

;; 可以写成:
(find-if (fint #'signed #'sealed #'delivered) docs)


;; 3.这种常见的模式:
(find-if #'(lambda (x)
             (or (signed x) (sealed x) (delivered x)))
         docs)

;; 可以写成:
(find-if (fun #'signed #'sealed #'delivered) docs)


9 闭包与数据结构

下面这段引用自 第6章:

通常说来,数据结构被用来描述事物。可以用数组描述坐标变换,用树结构表示命令的层次结构, 而用图来表示铁路网。在lisp里,我们常会使用闭包作为表现形式。在闭包里,变量绑定可以保存信 息,也能扮演在复杂数据结构中指针的角色。如果让一组闭包之间共享绑定,或者让它们之间能相互 引用,那么我们就可以创建混合型的对象类型,它同时继承了数据结构和程序逻辑两者的优点。 其实在表象之下,共享绑定就是指针。闭包只是让我们能在更高的抽象层面上操作指针。通过用 闭包来表示我们以往用静态数据结构表示的对象,就往往可能得到更为优雅,效率更好的程序。

比如说要实现下面这个 twenty questions 游戏:

> (run-node ’people)
Is the person a man?
>> yes
Is he living?
>> no
Was he American?
>> yes
Is he on a coin?
>> yes
Is the coin a penny?
>> yes
LINCOLN

版本1(数据结构版):

;; 存放name->node的关系
(defvar *nodes* (make-hash-table))

;; 存放每个node的数据
(defstruct node contents yes no)

;; 定义函数,用来向相应的数据结构存放内容
(defun defnode (name conts &optional yes no)
  (setf (gethash name *nodes*)
        (make-node :contents conts
                   :yes yes
                   :no no)))


;; 遍历函数,用来遍历数据结构,根据数据结构里的内容,产生不同的行为
(defun run-node (name)
  (let ((n (gethash name *nodes*)))
    (cond ((node-yes n)
           (format t "~a~%>> " (node-contents n))
           (case (read)
             (yes (run-node (node-yes n)))
             (t (run-node (node-no n)))))
          (t (node-contents n)))))

;; 定义函数的使用
(defnode 'people "Is the person a man?" 'male 'female)
(defnode 'male "Is he living?" 'liveman 'deadman)
(defnode 'deadman "Was he American?" 'us 'them)
(defnode 'us "Is he on a coin?" 'coin 'cidence)
(defnode 'coin "Is the coin a penny?" 'penny 'coins)
(defnode 'penny 'lincoln)

;; 遍历函数的使用;程序的入口
;; (run-node 'people)

其中数据结构如下图所示:

onlisp-01.png

版本2(closure版):

;; 存放name->closure的关系
(defvar *nodes* (make-hash-table))

;; 定义函数,生成对应closure,并且存放到*nodes*里
(defun defnode (name conts &optional yes no)
  (setf (gethash name *nodes*)
        (if yes
            #'(lambda ()
                (format t "~a~%>> " conts)
                (case (read)
                  (yes (funcall (gethash yes *nodes*)))
                  (t (funcall (gethash no *nodes*)))))
            #'(lambda () conts))))


;; 定义函数的使用
(defnode 'people "Is the person a man?" 'male 'female)
(defnode 'male "Is he living?" 'liveman 'deadman)
(defnode 'deadman "Was he American?" 'us 'them)
(defnode 'us "Is he on a coin?" 'coin 'cidence)
(defnode 'coin "Is the coin a penny?" 'penny 'coins)
(defnode 'penny 'lincoln)

;; 程序的入口
;; (funcall (gethash 'people *nodes*))


可以看到,该版本没有“遍历函数”了,使用的时候直接调用存放在 *nodes* 中已经生成的closure。

其中 *node* 的结构图如下:

onlisp-02.png

版本3(编译的closure):

;; 存放定义时数据
(defvar *nodes* nil)

;; 定义的函数
(defun defnode (&rest args)
  (push args *nodes*)
  args)

;; 根据 定义时存放的数据 来生成 整个运行的程序
(defun compile-net (root)
  (let ((node (assoc root *nodes*)))
    (if (null node)
        nil
        (let ((conts (second node))
              (yes (third node))
              (no (fourth node)))
          (if yes
              (let ((yes-fn (compile-net yes))
                    (no-fn (compile-net no)))
                #'(lambda ()
                    (format t "~a~%>>" conts)
                    (funcall (if (eq (read) 'yes)
                                 yes-fn
                                 no-fn))))
              #'(lambda () conts))))))

;; 定义函数的使用
(defnode 'people "Is the person a man?" 'male 'female)
(defnode 'male "Is he living?" 'liveman 'deadman)
(defnode 'deadman "Was he American?" 'us 'them)
(defnode 'us "Is he on a coin?" 'coin 'cidence)
(defnode 'coin "Is the coin a penny?" 'penny 'coins)
(defnode 'penny 'lincoln)

;; 程序的入口
;; (setf n (compile-net 'people))
;; (funcall n)


相应的数据结构和编译后的结构如下:

onlisp-03.png

其中在编译好的函数 n 后, *nodes* 已经可以垃圾回收了,里面相应的数据关系已经绑定到了闭包 n 中。

10 使用宏还是函数

10.1 当别无他法时

10.1.1 宏可以控制对参数的求值,可以求值一次,多次或者不求值

宏的这种控制主要体现在四个方面:

1.变换。例如 setf, (setf (car x) ’a) 需要 展开为 (progn (rplaca x ’a) ’a) 2.绑定。例如 let, 它的实参需要作为展开的lambda表达式的形参出现 3.条件求值。例如 when, 参数在条件为真时再求值 4.多重求职。例如do, 这样可以对特定的参数求值多次,比如每次的step form

10.1.2 宏展开式内联到宏调用的词法环境

这种优势体现在:

  1. 利用调用环境

(defmacro foo (x) `(+ ,x y))

  1. 包装新环境,比如let
  2. 减少函数调用,将运行时的开销转到了编译时期

值得注意的是,上面1,2两点也会产生变量捕捉等问题。

11 宏与于函数优缺点

11.1 宏优点

  • 编译期计算
  • 和lisp集成
  • 免除函数调用

11.2 函数优点

  • 函数即数据
  • 源代码清晰
  • 运行期清晰
  • 递归

12 宏陷阱

12.1 变量捕捉

12.1.1 宏参数捕捉

;; 宏定义
(defmacro for ((var start stop) &body body)
  `(do ((,var ,start (1+ ,var))
        (limit ,stop))
       ((> ,var limit))
     ,@body))

;; 使用case1
(for (x 1 5)
  (princ x))

;; 宏展开
(macroexpand-1 '(for (x 1 5)
                 (princ x)))

(DO ((X 1 (1+ X)) (LIMIT 5))
    ((> X LIMIT))
  (PRINC X))


;; 使用case2
(for (limit 1 5)
  (princ limit))

;; 宏展开
(macroexpand-1 '(for (limit 1 5)
                 (princ limit)))

(DO ((LIMIT 1 (1+ LIMIT)) (LIMIT 5))
    ((> LIMIT LIMIT))
  (PRINC LIMIT))

;; 使用case3
(let ((limit 5))
  (for (i 1 5)
    (when (> i limit)
      (princ i))))

;; 宏展开
(macroexpand-1 '(let ((limit 5))
                 (for (i 1 10)
                   (when (> i limit)
                     (princ i)))))
(LET ((LIMIT 5))
  (DO ((I 1 (1+ I))
       (LIMIT 10))
      ((> I LIMIT))
    (WHEN (> I LIMIT) (PRINC I))))


12.1.2 自由符号捕捉

(defvar w nil)

; wrong 这里的w会和在调用环境中的w产生作用
(defmacro gripe (warning)
 `(progn (setq w (nconc w (list ,warning)))
  nil))

12.2 求值次数

正确的版本:
(defmacro for ((var start stop) &body body)
  (let ((gstop (gensym)))
    `(do ((,var ,start (1+ ,var))
          (,gstop ,stop))
         ((> ,var ,gstop))
       ,@body)))

导致多重求值:
(defmacro for ((var start stop) &body body)
  `(do ((,var ,start (1+ ,var)))
       ((> ,var ,stop))
     ,@body))

12.3 求值顺序

错误的求值顺序:
(defmacro for ((var start stop) &body body)
  (let ((gstop (gensym)))
    `(do ((,gstop ,stop)
          (,var ,start (1+ ,var)))
         ((> ,var ,gstop))
        ,@body)))

使用:
> (let ((x 1))
    (for (i x (setq x 13))
      (princ i)))
12345678910111213
NIL

引用自原书10.2:
尽管上面的例子是杜撰的,但是这类问题确实还会时有发生,而且这种bug很难找出来。或许很少有人会写出这样的代码,让宏一个参数的求值影响到另一个参数的返回值,但是人们在无意中做的事情,有可能并非出自本心。尽管在有意这样用时,应当正常工作,但是这不是让bug藏身于实用工具的理由。如果有人写出的代码和前例相似,它很可能是误写成的,但 for 的正确版本将使错误更容易 检测出来。

12.4 非函数式的展开器

一个宏调用可以,并且经常会被展开不只一次。例如,一个对你代码进行变换的预处理器在它决定是否变换代码之前,可能不得不展 表达式中的宏调用。 这是一条普适的规则,即:展开器代码除其参数外不应依赖其他任何东西。所以任何宏,比如说通过字符串来构造展开式的那种,应当小心不要对宏展开时所在的包作任何假设。

;; case1 依赖全局变量来计数,假设每次调用展开一次(错误)
(defmacro nil! (x) ; wrong
 (incf *nil!s*)
`(setf ,x nil))



;; case2 依赖包,假设展开的包里含有opstring的定义(错误)
(defmacro string-call (opstring &rest args) ; wrong
  `(,(intern opstring) ,@args))

展开式代码中的副作用有时会带来一些问题,CLTL(78页)提到,Common Lisp并不保证绑定在 &rest 形参上的列表是新生成的。它们可能会和程序其他地方的列表共享数据结构。 后果就是,你不能破坏性地修改 &rest 形参,因为你不知道你将会改掉其他什么东西。

;; case3 修改&rest args列表
(defmacro echo (&rest args)
  `’,(nconc args (list ’amen)))

然后定义一个函数来调用它:
(defun foo () (echo x))

在一个广泛使用的Common Lisp中,则会观察到下面的现象:
> (foo)
(X AMEN AMEN)
> (foo)
(X AMEN AMEN AMEN)

;; 然而,我实验的两个实现ccl和sbcl都不出出现上述这个问题,看来是将这种易于出问题的情况规避了

12.5 递归

nth 的例子:

这个可以工作:
(defun ntha (n lst)
  (if (= n 0)
      (car lst)
      (ntha (- n 1) (cdr lst))))


这个不能编译依赖n的值,而编译器没有值,所以会一直展开下去:
(defmacro nthb (n lst)
  `(if (= ,n 0)
       (car ,lst)
       (nthb (- ,n 1) (cdr ,lst))))


解决方法:将宏改成宏和函数的组合

解决问题的方法一:
(defmacro nthd (n lst)
  `(nth-fn ,n ,lst))

(defun nth-fn (n lst)
  (if (= n 0)
      (car lst)
      (nth-fn (- n 1) (cdr lst))))

解决问题的方法而:
(defmacro nthe (n lst)
  `(labels ((nth-fn (n lst)
              (if (= n 0)
                  (car lst)
                  (nth-fn (- n 1) (cdr lst)))))
     (nth-fn ,n ,lst)))

or 的例子

;; case1 转化成宏和函数
(defmacro ora (&rest args)
  (or-expand args))

(defun or-expand (args)
  (if (null args)
      nil
      (let ((sym (gensym)))
        `(let ((,sym ,(car args)))
           (if ,sym
               ,sym
               ,(or-expand (cdr args)))))))

;; case2 这里递归调用自身没问题,因为它终止的条件是依赖参数个数,而不是值
(defmacro orb (&rest args)
  (if (null args)
      nil
      (let ((sym (gensym)))
        `(let ((,sym ,(car args)))
           (if ,sym
               ,sym
               (orb ,@(cdr args)))))))

13 常用宏

13.1 创建上下文

13.1.1 自定义let

;; 定义
CL-USER> (defmacro our-let (binds &body body)
           `((lambda ,(mapcar #'(lambda (x)
                             (if (consp x)
                                 (car x)
                                 x))
                         binds)
               ,@body)
             ,@(mapcar #'(lambda (x)
                           (if (consp x)
                               (cadr x)
                               nil))
                       binds)))
       OUR-LET

;; 效果
CL-USER> (our-let ((x 1) (y 2))
           (+ x y))
3

;; 展开成(macroexpand):
((LAMBDA (X Y) (+ X Y)) 1 2)

13.1.2 模仿let*的when-bind*

when-bind* 接受一个由成对的 (symbol expression) form 所组成的列表就和 let 的第一个参数的形式相同。如果任何 expression返回nil, 那整个when-bind*返回nil

;; 定义
CL-USER> (defmacro when-bind* (binds &body body)
           (if (null binds)
               `(progn ,@body)
               `(let (,(car binds))
                  (if ,(caar binds)
                      (when-bind* ,(cdr binds) ,@body)))))
WHEN-BIND*

CL-USER> (when-bind* ((x (find-if #'consp '(a (1 2) b)))
                      (y (find-if #'oddp x)))
           (+ y 10))
11
CL-USER>

;;  macroexpand
;; step1
(LET ((X (FIND-IF #'CONSP '(A (1 2) B))))
  (IF X
      (WHEN-BIND* ((Y (FIND-IF #'ODDP X)))
        (+ Y 10))))

;;step2
(LET ((X (FIND-IF #'CONSP '(A (1 2) B))))
  (IF X
      (LET ((Y (FIND-IF #'ODDP X)))
        (IF Y
            (WHEN-BIND* NIL
              (+ Y 10))))))

;; step3
(LET ((X (FIND-IF #'CONSP '(A (1 2) B))))
  (IF X
      (LET ((Y (FIND-IF #'ODDP X)))
        (IF Y
            (PROGN (+ Y 10))))))

13.1.3 with-gensyms

CL-USER>  (defmacro with-gensyms (syms &body body)
            `(let ,(mapcar (lambda (s) `(,s (gensym))) syms)
               ,@body))

13.1.4 condlet

宏效果: 对于表达式求值主体里的每个变量,如果那个cond条件满足,则用里面绑定的值,没有绑定的变量取nil

(condlet (((= 1 2) (x (princ ’a)) (y (princ ’b)))
          ((= 1 1) (y (princ ’c)) (x (princ ’d)))
          (t       (x (princ ’e)) (z (princ ’f))))
  (list x y z))

(condlet (((= 1 2) (x (princ 'a)) (y (princ 'b)))
                   ((= 1 1) (y (princ 'c)) (x (princ 'd)))
                   (t       (x (princ 'e)) (z (princ 'f))))
           (list x y z))
=>

CD
(D C NIL)


宏展开 =>

(LABELS ((#:G606 (Y X Z)
           (LIST X Y Z)))
  (COND
    ((= 1 2)
     (LET (#:G607 #:G608 #:G609)
       (LET ((#:G608 (PRINC ’A)) (#:G607 (PRINC ’B)))
         (#:G606 #:G607 #:G608 #:G609))))
    ((= 1 1)
     (LET (#:G607 #:G608 #:G609)
       (LET ((#:G607 (PRINC ’C)) (#:G608 (PRINC ’D)))
         (#:G606 #:G607 #:G608 #:G609))))
    (T
     (LET (#:G607 #:G608 #:G609)
       (LET ((#:G608 (PRINC ’E)) (#:G609 (PRINC ’F)))
         (#:G606 #:G607 #:G608 #:G609))))))

实现思路: 将cond绑定里的变量去重解析出来,每个变量分配一个gensym,求值主体放到一个labels函数里求值, 根据不同的情况给这个函数传入不同参数。 考虑到未绑定变量需要取nil值,那么采用两次let绑定,第一层全绑定nil, 第二层根据条件覆盖相应绑定,然后再给函数传参求值。

心得:像这种含有临时变量绑定的宏编写,需要将临时变量定义成gensym

;; 定义
(defmacro condlet (clauses &body body)
  (let ((bodfn (gensym))
        ;; here vars is like ((Y . #:G613) (X . #:G614) (Z . #:G615))
        (vars (mapcar #'(lambda (v) (cons v (gensym))) (remove-duplicates
                                                   (mapcar #'car
                                                           (mappend #'cdr clauses)))))
)
    `(labels ((,bodfn ,(mapcar #'car vars)
                ,@body))
       (cond ,@(mapcar #'(lambda (cl)
                           (condlet-clause vars cl bodfn))  ; 由于生成每个子表达式除了clauses不够,还要vars bodfn, 所以用个闭包将它们引入
                       clauses)))))

;; 作用:生产对应cond 语句
(defun condlet-clause (vars cl bodfn)
  `(,(car cl) (let ,(mapcar #'cdr vars)
                (let ,(condlet-binds vars cl)
                  (,bodfn ,@(mapcar #'cdr vars))))))

;; 作用:将表达式中的变量绑定,替换为对对应gensym的绑定
;; (condlet-binds '((Y . #:G613) (X . #:G614) (Z . #:G615)) '((= 1 2) (x (princ ’a)) (y (princ ’b))))
;; =>
;; ((#:G614 (PRINC ’A)) (#:G613 (PRINC ’B)))
(defun condlet-binds (vars cl)
  (mapcar #'(lambda (bindform)
              (if (consp bindform)
                  (cons (cdr (assoc (car bindform) vars))
                        (cdr bindform))))
          (cdr cl)))

;; 作用:将fn应用到lsts子项,再非破坏连接起来
;; (((= 1 2) (X (PRINC ’A)) (Y (PRINC ’B)))
;;  ((= 1 1) (Y (PRINC ’C)) (X (PRINC ’D))) (T (X (PRINC ’E)) (Z (PRINC ’F))))
;; =>
;; ((X (PRINC ’A)) (Y (PRINC ’B)) (Y (PRINC ’C)) (X (PRINC ’D)) (X (PRINC ’E))
;;                 (Z (PRINC ’F)))
(defun mappend (fn &rest lsts)
  "maps elements in list and finally appends all resulted lists."
  (apply #'append (apply #'mapcar fn lsts)))

13.2 with- 宏

只要一个操作符需要让求值的form在新的上下文求值,那久应该将它定义成宏。比如 ignore-errors 宏,使参数像在一个 progn 里求值,但不管什么地方出了错,整体返回nil。

with-open-file 宏展开式包含一个 unwind-protect ,确保打开的文件的关闭。

13.3 条件求值

13.4 条件求值

有时候需要让宏调用的参数在一定条件下求值,其它不求值,这时候就超出了函数的能力。虽然像 if , andcond 这些内置操作符在“短路”的情况下可以避免对参数求值。但使用宏使更加强大。

下面这个宏 in 是用来检测元素是否在集合中,但可以避免一次性将集合中元素都求值。 比如想检测表达式 (foo) 的值是不是在表达式 (bar)(baz) 之间,我们可以这样:

(member (foo) (list (bar) (baz)))

但这种效率差些,因为首先它将 (bar) 和 (baz) 结果连接成列表, 其次如果 (bar) 的结果和 (foo) 相等,那就没必要求值 (baz) , 所以可以写一个 in 宏,利用 or 的短路特性和宏对于参数的可控制求值:

(defmacro in (obj &rest choices)
  (let ((g (gensym)))
    `(let ((,g ,obj))
       (or ,@(mapcar (lambda (x) `(eql ,g ,x))
                     choices)))))

变形1: inqin 的引用变形,类似于 setq 之于 set 。将 &rest 参数都当成symbol来看待。

(defmacro inq (obj &rest choices)
  `(in ,obj ,@(mapcar (lambda (c) `',c) choices)))

这样

(inq operator + - *)

;;展开成
(in operator '+ '- '*)


(inq some-symbol a b c)

;; 展开成
(in some-symbol 'a 'b 'c)

变形2: in 默认采用 eql 求值, 如果需要其它求值条件或某个一元函数,那么可用下面这个更通用的 in-if :

(defmacro in-if (fn &rest choices)
  `(or ,@(mapcar (lambda (x) `(funcall ,fn ,x))
                 choices)))

这样像

(member x (list a b) :test #'equal)

;; 可以写成

(in-if #'(lambda (y) (equal x y)) a b)

(some #'oddp (list a b))

;; 可以写成
(in-if #'oddp a b)

in-if 之于 some 好比 in 之于 memberin-if 相比于 some 不需要将要比较的元素cons,而且不用事先求值。

13.5 迭代

用do宏演变出其它语言中常见循环模式: while , till , for

(defmacro while (test &body body)
  `(do ()
       ((not ,test))
     ,@body))

(defmacro till (test &body  body)
  `(do ()
       (,test)
     ,@body))

(defmacro for ((var start stop) &body body)
  (with-gensyms (gstop)
    `(do ((,var ,start (1+ ,var))
          (,gstop ,stop))
         ((> ,var ,gstop))
       ,@body)))

两个比 dolist 更一般的宏:两者在求值主体时绑定一组变量到一个列表中的相继的子序列上,

CL-USER> (do-tuples/o (x y z) '(a b c d e f g)
           (princ (list x y z)))
(A B C)(B C D)(C D E)(D E F)(E F G)
NIL


CL-USER> (do-tuples/c (x y z) '(a b c d e f g)
           (princ (list x y z)))
(A B C)(B C D)(C D E)(D E F)(E F G)(F G A)(G A B)
NIL

其中 do-tuples/o 是开放的,当最后一个变量到达绑定的列表结尾便停止, 而 do-tuples/c 会继续直到第一个变量达到结尾。宏的定义如下:

(defmacro do-tuples/o (parms source &body body)
  (if parms
      (let ((src (gensym)))
        `(prog ((,src ,source))
            (mapc (lambda ,parms ,@body)
                  ,@(map0-n (lambda (n)
                              `(nthcdr ,n ,src))
                            (1- (length parms))))))))

;; Here is a limit in the macro,
;; length of parms should <= length of source * 2
(defmacro do-tuples/c (parms source &body body)
  (if parms
      (let ((src (gensym)))
        `(prog ((,src ,source))
            (mapc (lambda ,parms ,@body)
                  ,@(map0-n (lambda (n)
                              `(append (nthcdr ,n ,src) (subseq ,src 0 ,n)))
                            (1- (length parms))))))))


这里采用的技巧是 mapc 接受的 fn 的参数得和 mapc 接受的lists参数个数一样,而且fn的参数从各个列表中依次取值, 所以通过控制mapc的参数lists,来控制迭代进行的次数。

14 END

Modified: 2018-11-27

Author: Nisen

Email: imnisen@163.com