如何扩展 cl-loop

事情是这样的,我的恋人@misaka18931在配置她的 Emacs 时陷入了苦恼。她在写循环,于是我建议她使用强大的 cl-loop 。可是她告诉我 cl-loop 也无法解决她的问题,因为她需要找到一个 alist 中 value 最大的 cons cell 的 key 。太糟糕了,这确实是 cl-loop 无法解决的问题。在 Common Lisp 中我一般会使用 Jonathan Amsterdam 的强大可扩展迭代器解决这类问题。于是我首先想到的是把 Jonathan Amsterdam 的强大可扩展迭代器 移植到 Elisp 里,但是这不太现实,因为它需要构建一个完整的 code walker 。那么退而求其次,能不能扩展 cl-loop ,让它支持 finding X maximizing Y 的功能呢?

我开始查找资料,但只在 cl-loop 的 Info Page 最末一节的倒数第二段找到这么两句:

While there is no high-level way to add user extensions to ‘cl-loop’,
this package does offer two properties called ‘cl-loop-handler’ and
‘cl-loop-for-handler’ which are functions to be called when a given
symbol is encountered as a top-level loop clause or ‘for’ clause,
respectively.  Consult the source code in file ‘cl-macs.el’ for details.

…真是把我们 Lisp 程序员当肉编器用。好吧, M-. 打开 cl-macs.el ,在 cl-loop parser 的最末找到这么一个不情不愿的条件句:

(t
 ;; This is an advertised interface: (info "(cl)Other Clauses").
 (let ((handler (and (symbolp word) (get word 'cl-loop-handler))))
   (or handler (error "Expected a cl-loop keyword, found %s" word))
   (funcall handler)))

注意到 word 就是存储当前 loop 关键字的变量。于是得出扩展 Loop clauses 的方法是:

(setf (get 'my-keyword 'cl-loop-handler) (lambda () ...))

注意到扩展函数接受 0 个参数,说明所有操作都要通过修改 dynamic variable (也就是 lexically bounded special variable,在词法作用域中绑定的特殊变量)进行。更头大的是这些变量一丁点说明和注释都没有:

;;; The "cl-loop" macro.

(defvar cl--loop-args) (defvar cl--loop-accum-var) (defvar cl--loop-accum-vars)
(defvar cl--loop-bindings) (defvar cl--loop-body) (defvar cl--loop-conditions)
(defvar cl--loop-finally)
(defvar cl--loop-finish-flag)           ;Symbol set to nil to exit the loop?
(defvar cl--loop-first-flag)
(defvar cl--loop-initially) (defvar cl--loop-iterator-function)
(defvar cl--loop-name)
(defvar cl--loop-result) (defvar cl--loop-result-explicit)
(defvar cl--loop-result-var) (defvar cl--loop-steps)
(defvar cl--loop-symbol-macs)

注意到:

  • cl--loop-args 是亟待处理的参数列表,使用 pop 提取下一个元素
  • cl--loop-bindings 是一个 let 参数列表的列表,是在运行时生效的词法绑定(即局部变量定义),使用 push 向后追加内容(最后会nreverse
  • cl--loop-result 是一般情况下的返回值表达式
  • cl--loop-result-explicit 是通过 finally return Xfinally (return X) 指定的返回值表达式
  • cl--loop-accum-vars 是收集器(accumulating clauses)所创建并使用的变量名,包括默认变量和通过 into 关键字创建的命名变量
  • cl--loop-accum-var 是未指定 into 时收集器的默认目标变量名
    • (cl--loop-handle-accum [init-value]) 可用于创建收集器变量名,自动解析 into 关键字
  • cl--loop-body 是循环体,是一个表达式列表,其中的任一表达式返回 nil 则终止整个 cl-loop 循环并开始返回。使用 push 向后追加内容(最后会nreverse

本人注意力有限,其它变量的用法大家可以望文生一下义。

有了这些信息,我们就可以编写 cl-loop 的扩展啦~拿我们的 finding ,finding-expression maximizing ,maximizing-expression 为例,注意到我们可以通过如下方式实现:

(let (peak-score peak-value) ; bindings
  (loop ...
        (let ((this-score ,maximizing-expression)) ; body
          (when (or (null peak-score)
                    (> this-score peak-score))
            (setq peak-score this-score
                  peak-value ,finding-expression)))
        ...)
  peak-value) ; return value

只需要在我们的函数中,将每个部分的代码一一 push 到对应的 cl--loop-* 变量里,我们的 cl-loop 扩展就完成啦w~

完整的 Jonathan Amsterdam 的强大可扩展迭代器之寻找者 - cl-loop 版 源代码如下:

(defun cal/cl-loop-finding-handler ()
  "April's powerless finding handler that poorly imitating
Jonathan Amsterdam's powerful iteration facility"
  (let* ((expr (pop cl--loop-args))
         (kind (cl-case (pop cl--loop-args)
                 ((maximize maximizing) 'max)
                 ((minimize minimizing) 'min)
                 (such-that 'such-that)
                 (t (error "Invalid finding clause"))))
         (test-expr (pop cl--loop-args))
         (value (cl--loop-handle-accum nil)))
    (if (eq kind 'such-that)
        (let ((test-result (gensym "--cl-var--finder-test-result-")))
          (push `((,test-result nil))
                cl--loop-bindings)
          (push `(progn (setq ,test-result ,(if (and (listp test-expr) (eq (car test-expr) 'function))
                                                `(funcall ,test-expr ,expr)
                                              test-expr))
                        (when ,test-result
                          (setq ,value ,expr))
                        (null ,test-result))
                cl--loop-body))
      (let ((peak-score (gensym "--cl-var--finder-peak-score-"))
            (this-score (gensym "--cl-var--finder-this-score-")))
        (push `((,peak-score nil) (,this-score nil))
              cl--loop-bindings)
        (push `(progn (setq ,this-score ,(if (and (listp test-expr) (eq (car test-expr) 'function))
                                             `(funcall ,test-expr ,expr)
                                           test-expr))
                      (when (or (null ,peak-score)
                                (,(if (eql kind 'max) '> '<) ,this-score ,peak-score))
                        (setq ,peak-score ,this-score
                              ,value ,expr))
                      t)
              cl--loop-body)))))

;; Install handler
(setf (get 'find    'cl-loop-handler) #'cal/cl-loop-finding-handler)
(setf (get 'finding 'cl-loop-handler) #'cal/cl-loop-finding-handler)

可以看到,虽然比 Jonathan Amsterdam 的强大可扩展迭代器defmacro-driver 扩展接口要冗长一些,但依然是简短且可接受的,这充分证明了我们同样强大的 cl-loop 同样具有可扩展能力。下面让我们进行一些简单的测试:

(cl-loop for i from -10 by 0.3
         finding i such-that #'cl-plusp) ; => 0.2000000000000009

(cl-loop for (key value) on '(:a 1 :c 3 :b 2) by #'cddr
         finding key maximizing value) ; => :c

呃,似乎看到了一些不太干净的东西…不过不要紧,我们的寻找者基本正确工作!好诶!

经过我们戮力同心的探索,相信大家已经掌握如何扩展 cl-loop 啦w~需要注意的是, cl-loop 有两种扩展 handler :cl-loop-handlercl-loop-for-handler ,后者可以用来实现诸如 loop for (key val) in-plist X 之类的功能,想必读者自证不难。如果大家有什么好点子,但自己的 Emacs buffer 篇幅有限写不太下,这边也提供工人智能无偿代写服务(

最后祝大家春节快乐, Happy Hacking! (っ´ω`)っ♡

8 个赞

老婆好厉害 >_< 爱你爱你 祝大家春节以及情人节快乐喵~

(caar (cl-sort (cl-copy-list alist) '> :key 'cdr))
(cl-labels ((maxcdr (x y) (if (> (cdr x) (cdr y)) x y)))
  (car (cl-reduce #'maxcdr alist)))

在PI通过图灵检测之后 我已经无法辨识网上的内容是否由憎恶智能生成… 这个不能使用foldl实现嘛?

用了一点 haskell 里的手段

(defun on (op f)
  (lambda (x y)
    (funcall op
     (funcall f x)
     (funcall f y))))
(defun sel (test)
  (lambda (x y)
    (if (funcall test x y) x y)))
(car (reduce (sel (on '> 'cdr)) alist))

更干净的 scheme 版本

(define (on op f)
  (lambda (x y)
    (op (f x) (f y))))
(define (sel test)
  (lambda (x y)
    (if (test x y) x y)))
(car (reduce (sel (on > cdr)) alist))

select by greater-than on cdr