Common lisp 哪些标准的通用Lisp宏/特殊形式建立了名为nil的隐式块？

DO、PROG等在其身体周围建立一个名为nil的隐式块。CLHS没有提供所有执行此操作的标准宏的列表。到目前为止，我所知道的是：

DO
DO*
PROG
PROG*
LOOP
DOLIST
DOTIMES
DO-SYMBOLS
DO-ALL-SYMBOLS
DO-EXTERNAL-SYMBOLS

---

是否有其他标准CL宏或特殊形式建立隐式nil块？

我相信问题中的列表是完整的。我的证据是实验性的，不是从检查CLH的每一页中得出的；这就是我所做的，为了所有想检查我没有遗漏任何重要信息的人。最后有一个警告列表

首先，使用一个简单的函数检查宏扩展是否有一个名为NIL的块。它将找到不在顶级的NIL块。它可能有误报，因此需要手动检查输出

(defun has-nil-block (x)
  (labels ((helper (items)
             (and (consp items) (or (has-nil-block (first items)) (helper (rest items))))))
    (and (consp x) (or (and (eq (first x) 'block) (eq (second x) nil))
                       (helper x)))))

然后，我选择了我手头最方便的CL实现，它恰好是CLISP，并这样做：

(let ((syms nil))
  (do-symbols (sym (find-package "COMMON-LISP"))
    (when (macro-function sym) (push sym syms)))
  syms)

这给了我以下列表（没有特定顺序，包括重复符号，包括CLHS中定义为特殊运算符的一些但不是所有符号）：

然后，我将这些运算符与CLHS第3.1.2.1.2.1节中列出的特殊运算符一起，删除了CLHS中未提及的运算符，删除了重复的运算符，为每个运算符编写了一个典型调用（在某些情况下不止一个），然后检查了调用MACROEXPAND-1和MACROEXPAND的结果：

(let ((candidates '(
  ;; special operators as defined in CLHS 3.1.2.1.2.1
  (block wombat)
  (catch a-tag t)
  (eval-when (:compile-toplevel :load-toplevel :execute) t)
  (flet ((f (x) x)) (f t))
  (function (x) t)
  (go bananas)
  (if (some-function) 123 234)
  (labels ((f (x) x) (g (x) (1+ (f x)))) (g (banana)))
  (let ((x 1) (y 2)) (+ x y))
  (let* ((x 1) (y 2)) (+ x y))
  (load-time-value 123)
  (load-time-value 123 t)
  (locally (declare (special x)) x)
  (macrolet ((zog (x) x)) (zog 123))
  (multiple-value-call #'list 1 (values 2 3) 4)
  (multiple-value-prog1 (values 1 2) (values 2 3))
  (progn (f) (g) (h))
  (progv '(*x* *y* *z*) '(1 2 3) (+ *x* *y* *z*))
  (quote 123)
  (return-from some-name 123)
  (setq x 1 y 2 z 3)
  (symbol-macrolet ((x '(foo x))) (list x))
  (tagbody (foo) x (bar) (go x))
  (the double-float 1.234d0)
  (throw 'ouch 123)
  (unwind-protect (foo) (bar))
  ;; symbols in COMMON-LISP package for which MACRO-FUNCTION evaluates to true in CLISP
  ;(call-method (make-method t)) ;; this is kinda illegal
  (with-slots ((xx x) (yy y)) an-object (list xx yy))
  (defgeneric f (a b) (:method ((a integer) (b integer)) 123))
  (define-method-combination fnord :identity-with-one-argument t)
  (define-method-combination zorg () ((around (:around)) (primary (zorg) :required t)) t)
  (defmethod foo ((a double-float) b) (+ a b))
  (with-accessors ((xx x) (yy y)) an-object (list xx yy))
  (do-symbols (sym :COMMON-LISP) nil)
  (do-all-symbols (sym :COMMON-LISP) nil)
  (do-external-symbols (sym :COMMON-LISP) nil)
  (do (x (y 1 2)) ((ended) (final x y)) (foo x y))
  (do* (x (y 1 2)) ((ended) (final x y)) (foo x y))
  (dotimes (i 3) (foo i))
  (dolist (x (get-list)) (foo x))
  (rotatef a b c)
  (shiftf a b c)
  (typecase an-object ((integer 1) (otherwise 2)))
  (ctypecase an-object ((integer 1) (otherwise 2)))
  (etypecase an-object ((integer 1) (otherwise 2)))
  (ignore-errors (foo))
  (check-type x integer)
  (handler-bind ((unbound-variable #'(lambda (x) x))) (foo))
  (handler-case (foo) (unbound-variable (c) (bar c)))
  (lambda (x) x)
  (case x ((1) t) (otherwise 'zog))
  (ccase x ((1) t) (otherwise 'zog))
  (ecase x ((1) t) (otherwise 'zog))
  (decf x)
  (incf x)
  (defconstant +x+ 123)
  (defparameter *x* 123)
  (defvar *x* 123)
  (deftype zoo () `(and (array) (satisfies (lambda (a) (eql (array-rank a) 1)))))
  (defstruct boo slot1 slot2)
  (defstruct (boo :constructor :copier :predicate (:print-object pfun)) slot1 slot2)
  (defclass trivclass () ())
  (defpackage :SOME-PACKAGE)
  (in-package :SOME-PACKAGE (foo))
  (with-package-iterator (iter :COMMON-LISP :internal :external :inherited) 123)
  (with-package-iterator (iter :COMMON-LISP :internal :external :inherited) (foo (iter)))
  (with-hash-table-iterator (iter (get-hash-table)) (foo (iter)))
  (destructuring-bind (x y) (foo) (list y x))
  (with-simple-restart (abort "Exit") (foo))
  (restart-bind ((my-restart (get-restart-function))) (foo))
  (restart-case (foo) (my-restart (x) x))
  (with-condition-restarts (get-condition) (get-restarts) (foo))
  (push (foo) some-list)
  (pushnew (foo) some-list)
  (pop some-list)
  (with-input-from-string (ss (get-string)) (foo ss))
  (with-output-to-string (ss) (foo ss))
  (define-condition my-condition () ())
  (defun foo () 123)
  (defmacro foo (&rest body) body)
  (define-symbol-macro foo (call-foo))
  (define-modify-macro appendf (&rest args) append "Append onto list")
  (define-compiler-macro foo (&rest body) `(call-foo . ,body))
  (defsetf accessor updater)
  (defsetf accessor (x spong) (result) result)
  (step (foo))
  (with-open-file (ss (get-filespec) :direction :input) (foo ss))
  (with-open-stream (st (get-stream)) (foo st))
  (and (foo) (bar) (baz))
  (or (foo) (bar) (baz))
  (multiple-value-setq (x y z) (foo))
  (multiple-value-list (foo))
  (psetq x 1 y 2 z 3)
  (psetf x 1 y 2 z 3)
  (setf x 1 y 2 z 3)
  (remf (car x) 'property)
  (cond ((foo) 123) ((bar) 321) (t 999))
  (when (foo) (bar) (baz))
  (unless (foo) (bar) (baz))
  (trace banana)
  (untrace banana)
  (prog1 (foo) (bar) (baz))
  (prog2 (foo) (bar) (baz))
  (prog (x y z) (foo x) aaa (foo y) (go aaa) (foo z))
  (prog* (x y z) (foo x) aaa (foo y) (go aaa) (foo z))
  (nth-value (get-index) (get-values))
  (assert (foo))
  (with-standard-io-syntax (foo))
  (time (foo))
  (formatter "~&~A~%")
  (with-compilation-unit () (foo))
  (loop (foo))
  (loop for x in (foo) do (bar x))
  (return 123)
  (pprint-logical-block (stream thing) (foo))
  (print-unreadable-object (obj stream) (foo))
  (declare ((optimize (space 0))))
  )))
  (loop for candidate in candidates do
    (let ((one (macroexpand-1 candidate))
          (two (macroexpand candidate)))
      (cond ((has-nil-block one)
             (format t "~&~%~A~%  ==> ~A~%" candidate one))
            ((has-nil-block two)
             (format t "~&~%~A~%  ==> ~A~%  ...--> ~A~%" candidate one two))))))

对于任何候选宏调用，（1）它是否直接（通过MACROEXPAND-1）扩展到包含（块NIL…）的对象，以及（2）如果没有，它是否间接（通过MACROEXPAND）扩展到包含（块NIL…）的对象。它显示宏展开，以便您可以确保它们不是误报

结果如下（我删掉了一些警告信息）：

正如你所看到的，它包括了原始问题中列出的所有符号，没有其他符号

这可能出现错误的方式有：（1）调用给定宏是否生成nil块可能取决于调用的细节。我特意为所有宏选择了很好的简单调用，而且（例如）DEFCLASS的一些巴洛克实例可能会做一些创建nil块的事情。（2） 我可能错过了宏列表中的一些项。（我的候选列表有点像CLISP输出的顺序，但我重新排列了它，以便将相关的宏放在一起。）（3）CLISP在相关方面可能是非标准的

---

我相当有信心，事实上，这些都不会使我的结果无效。将“相当自信”变为“近乎绝对肯定”可能意味着将所需工作量增加一倍：-）。

你为什么想知道？这是为Parenscript准备的。我想任何其他从事编译或翻译工作的人都会发现这些信息很有用（我计划在CLiki上发布一个权威列表）。

(let ((candidates '(
  ;; special operators as defined in CLHS 3.1.2.1.2.1
  (block wombat)
  (catch a-tag t)
  (eval-when (:compile-toplevel :load-toplevel :execute) t)
  (flet ((f (x) x)) (f t))
  (function (x) t)
  (go bananas)
  (if (some-function) 123 234)
  (labels ((f (x) x) (g (x) (1+ (f x)))) (g (banana)))
  (let ((x 1) (y 2)) (+ x y))
  (let* ((x 1) (y 2)) (+ x y))
  (load-time-value 123)
  (load-time-value 123 t)
  (locally (declare (special x)) x)
  (macrolet ((zog (x) x)) (zog 123))
  (multiple-value-call #'list 1 (values 2 3) 4)
  (multiple-value-prog1 (values 1 2) (values 2 3))
  (progn (f) (g) (h))
  (progv '(*x* *y* *z*) '(1 2 3) (+ *x* *y* *z*))
  (quote 123)
  (return-from some-name 123)
  (setq x 1 y 2 z 3)
  (symbol-macrolet ((x '(foo x))) (list x))
  (tagbody (foo) x (bar) (go x))
  (the double-float 1.234d0)
  (throw 'ouch 123)
  (unwind-protect (foo) (bar))
  ;; symbols in COMMON-LISP package for which MACRO-FUNCTION evaluates to true in CLISP
  ;(call-method (make-method t)) ;; this is kinda illegal
  (with-slots ((xx x) (yy y)) an-object (list xx yy))
  (defgeneric f (a b) (:method ((a integer) (b integer)) 123))
  (define-method-combination fnord :identity-with-one-argument t)
  (define-method-combination zorg () ((around (:around)) (primary (zorg) :required t)) t)
  (defmethod foo ((a double-float) b) (+ a b))
  (with-accessors ((xx x) (yy y)) an-object (list xx yy))
  (do-symbols (sym :COMMON-LISP) nil)
  (do-all-symbols (sym :COMMON-LISP) nil)
  (do-external-symbols (sym :COMMON-LISP) nil)
  (do (x (y 1 2)) ((ended) (final x y)) (foo x y))
  (do* (x (y 1 2)) ((ended) (final x y)) (foo x y))
  (dotimes (i 3) (foo i))
  (dolist (x (get-list)) (foo x))
  (rotatef a b c)
  (shiftf a b c)
  (typecase an-object ((integer 1) (otherwise 2)))
  (ctypecase an-object ((integer 1) (otherwise 2)))
  (etypecase an-object ((integer 1) (otherwise 2)))
  (ignore-errors (foo))
  (check-type x integer)
  (handler-bind ((unbound-variable #'(lambda (x) x))) (foo))
  (handler-case (foo) (unbound-variable (c) (bar c)))
  (lambda (x) x)
  (case x ((1) t) (otherwise 'zog))
  (ccase x ((1) t) (otherwise 'zog))
  (ecase x ((1) t) (otherwise 'zog))
  (decf x)
  (incf x)
  (defconstant +x+ 123)
  (defparameter *x* 123)
  (defvar *x* 123)
  (deftype zoo () `(and (array) (satisfies (lambda (a) (eql (array-rank a) 1)))))
  (defstruct boo slot1 slot2)
  (defstruct (boo :constructor :copier :predicate (:print-object pfun)) slot1 slot2)
  (defclass trivclass () ())
  (defpackage :SOME-PACKAGE)
  (in-package :SOME-PACKAGE (foo))
  (with-package-iterator (iter :COMMON-LISP :internal :external :inherited) 123)
  (with-package-iterator (iter :COMMON-LISP :internal :external :inherited) (foo (iter)))
  (with-hash-table-iterator (iter (get-hash-table)) (foo (iter)))
  (destructuring-bind (x y) (foo) (list y x))
  (with-simple-restart (abort "Exit") (foo))
  (restart-bind ((my-restart (get-restart-function))) (foo))
  (restart-case (foo) (my-restart (x) x))
  (with-condition-restarts (get-condition) (get-restarts) (foo))
  (push (foo) some-list)
  (pushnew (foo) some-list)
  (pop some-list)
  (with-input-from-string (ss (get-string)) (foo ss))
  (with-output-to-string (ss) (foo ss))
  (define-condition my-condition () ())
  (defun foo () 123)
  (defmacro foo (&rest body) body)
  (define-symbol-macro foo (call-foo))
  (define-modify-macro appendf (&rest args) append "Append onto list")
  (define-compiler-macro foo (&rest body) `(call-foo . ,body))
  (defsetf accessor updater)
  (defsetf accessor (x spong) (result) result)
  (step (foo))
  (with-open-file (ss (get-filespec) :direction :input) (foo ss))
  (with-open-stream (st (get-stream)) (foo st))
  (and (foo) (bar) (baz))
  (or (foo) (bar) (baz))
  (multiple-value-setq (x y z) (foo))
  (multiple-value-list (foo))
  (psetq x 1 y 2 z 3)
  (psetf x 1 y 2 z 3)
  (setf x 1 y 2 z 3)
  (remf (car x) 'property)
  (cond ((foo) 123) ((bar) 321) (t 999))
  (when (foo) (bar) (baz))
  (unless (foo) (bar) (baz))
  (trace banana)
  (untrace banana)
  (prog1 (foo) (bar) (baz))
  (prog2 (foo) (bar) (baz))
  (prog (x y z) (foo x) aaa (foo y) (go aaa) (foo z))
  (prog* (x y z) (foo x) aaa (foo y) (go aaa) (foo z))
  (nth-value (get-index) (get-values))
  (assert (foo))
  (with-standard-io-syntax (foo))
  (time (foo))
  (formatter "~&~A~%")
  (with-compilation-unit () (foo))
  (loop (foo))
  (loop for x in (foo) do (bar x))
  (return 123)
  (pprint-logical-block (stream thing) (foo))
  (print-unreadable-object (obj stream) (foo))
  (declare ((optimize (space 0))))
  )))
  (loop for candidate in candidates do
    (let ((one (macroexpand-1 candidate))
          (two (macroexpand candidate)))
      (cond ((has-nil-block one)
             (format t "~&~%~A~%  ==> ~A~%" candidate one))
            ((has-nil-block two)
             (format t "~&~%~A~%  ==> ~A~%  ...--> ~A~%" candidate one two))))))

(DO-SYMBOLS (SYM COMMON-LISP) NIL)
  ==>
(BLOCK NIL
 (LET ((PACKAGE-4169 COMMON-LISP))
  (LET ((SYM NIL)) (DECLARE (IGNORABLE SYM))
   (MAP-SYMBOLS #'(LAMBDA (SYM) (TAGBODY NIL)) PACKAGE-4169) NIL)))

(DO-ALL-SYMBOLS (SYM COMMON-LISP) NIL)
  ==>
(BLOCK NIL
 (LET ((SYM NIL)) (DECLARE (IGNORABLE SYM)) (MAP-ALL-SYMBOLS #'(LAMBDA (SYM) (TAGBODY NIL)))
  COMMON-LISP))

(DO-EXTERNAL-SYMBOLS (SYM COMMON-LISP) NIL)
  ==>
(BLOCK NIL
 (LET ((PACKAGE-4171 COMMON-LISP))
  (LET ((SYM NIL)) (DECLARE (IGNORABLE SYM))
   (MAP-EXTERNAL-SYMBOLS #'(LAMBDA (SYM) (TAGBODY NIL)) PACKAGE-4171) NIL)))

(DO (X (Y 1 2)) ((ENDED) (FINAL X Y)) (FOO X Y))
  ==>
(BLOCK NIL
 (LET (X (Y 1))
  (TAGBODY LOOP-4173 (IF (ENDED) (GO END-4174)) (FOO X Y) (PSETQ Y 2) (GO LOOP-4173) END-4174
   (RETURN-FROM NIL (PROGN (FINAL X Y))))))

(DO* (X (Y 1 2)) ((ENDED) (FINAL X Y)) (FOO X Y))
  ==>
(BLOCK NIL
 (LET* (X (Y 1))
  (TAGBODY LOOP-4177 (IF (ENDED) (GO END-4178)) (FOO X Y) (SETQ Y 2) (GO LOOP-4177) END-4178
   (RETURN-FROM NIL (PROGN (FINAL X Y))))))

(DOTIMES (I 3) (FOO I))
  ==> (DO ((I 0 (1+ I))) ((>= I 3) NIL) (FOO I))
  ...-->
(BLOCK NIL
 (LET ((I 0))
  (TAGBODY LOOP-4181 (IF (>= I 3) (GO END-4182)) (FOO I) (PSETQ I (1+ I)) (GO LOOP-4181) END-418
   (RETURN-FROM NIL (PROGN NIL)))))

(DOLIST (X (GET-LIST)) (FOO X))
  ==>
(DO* ((LIST-4183 (GET-LIST) (CDR LIST-4183)) (X NIL)) ((ENDP LIST-4183) NIL)
 (DECLARE (LIST LIST-4183)) (SETQ X (CAR LIST-4183)) (FOO X))
  ...-->
(BLOCK NIL
 (LET* ((LIST-4184 (GET-LIST)) (X NIL)) (DECLARE (LIST LIST-4184))
  (TAGBODY LOOP-4185 (IF (ENDP LIST-4184) (GO END-4186)) (SETQ X (CAR LIST-4184)) (FOO X)
   (SETQ LIST-4184 (CDR LIST-4184)) (GO LOOP-4185) END-4186 (RETURN-FROM NIL (PROGN NIL)))))

(PROG (X Y Z) (FOO X) AAA (FOO Y) (GO AAA) (FOO Z))
  ==> (BLOCK NIL (LET (X Y Z) (TAGBODY (FOO X) AAA (FOO Y) (GO AAA) (FOO Z))))

(PROG* (X Y Z) (FOO X) AAA (FOO Y) (GO AAA) (FOO Z))
  ==> (BLOCK NIL (LET* (X Y Z) (TAGBODY (FOO X) AAA (FOO Y) (GO AAA) (FOO Z))))

(LOOP (FOO))
  ==> (BLOCK NIL (TAGBODY LOOP-4350 (FOO) (GO LOOP-4350)))

(LOOP FOR X IN (FOO) DO (BAR X))
  ==>
(MACROLET ((LOOP-FINISH NIL (LOOP-FINISH-ERROR)))
 (BLOCK NIL
  (LET ((LIST-4352 (FOO)))
   (PROGN
    (LET ((X NIL))
     (LET NIL
      (MACROLET ((LOOP-FINISH NIL '(GO END-LOOP)))
       (TAGBODY BEGIN-LOOP (WHEN (ENDP LIST-4352) (LOOP-FINISH)) (SETQ X (CAR LIST-4352))
        (PROGN (PROGN (BAR X))) (PSETQ LIST-4352 (CDR LIST-4352)) (GO BEGIN-LOOP) END-LOOP
        (MACROLET ((LOOP-FINISH NIL (LOOP-FINISH-WARN) '(GO END-LOOP))))))))))))