common-lisp - 哪些标准 Common Lisp 宏/特殊形式建立了名为 nil 的隐式 block ？

Question

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

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

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

Answer 1

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

首先，一个简单的函数来检查宏扩展是否有一个名为 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 中定义为特殊运算符的符号):

(CALL-METHOD GENERIC-FLET WITH-SLOTS GENERIC-LABELS CLOS-WARNING DEFGENERIC
 DEFINE-METHOD-COMBINATION MAKE-METHOD DEFMETHOD DEFCLASS WITH-ACCESSORS
 DO-EXTERNAL-SYMBOLS DOTIMES ROTATEF ETYPECASE IGNORE-ERRORS CHECK-TYPE
 TYPECASE MAKE-METHOD DEFMETHOD CTYPECASE WITH-SLOTS WITH-PACKAGE-ITERATOR
 HANDLER-BIND LAMBDA ECASE DEFINE-MODIFY-MACRO DECF DEFCLASS DEFPARAMETER
 DESTRUCTURING-BIND WITH-SIMPLE-RESTART POP WITH-OUTPUT-TO-STRING
 DEFINE-CONDITION DEFUN STEP WITH-OPEN-FILE AND MULTIPLE-VALUE-SETQ COND
 CALL-METHOD DEFCONSTANT DEFMACRO WHEN MULTIPLE-VALUE-LIST UNTRACE PROG2
 DEFGENERIC PROG1 PUSHNEW PROG* DEFTYPE DEFINE-METHOD-COMBINATION
 WITH-OPEN-STREAM OR WITH-ACCESSORS SHIFTF INCF PUSH HANDLER-CASE NTH-VALUE
 DEFSTRUCT RESTART-CASE PSETQ WITH-INPUT-FROM-STRING ASSERT SETF PSETF
 DEFPACKAGE LOOP-FINISH WITH-STANDARD-IO-SYNTAX DEFINE-SYMBOL-MACRO TIME
 IN-PACKAGE FORMATTER DO-SYMBOLS CASE LOCALLY DO REMF DO* WITH-COMPILATION-UNIT
 LOOP RETURN WITH-CONDITION-RESTARTS PPRINT-LOGICAL-BLOCK CCASE TRACE DEFVAR
 PRINT-UNREADABLE-OBJECT DEFINE-COMPILER-MACRO PROG RESTART-BIND DO-ALL-SYMBOLS
 UNLESS DECLAIM DEFINE-SETF-EXPANDER MULTIPLE-VALUE-BIND DEFSETF
 WITH-HASH-TABLE-ITERATOR DOLIST DECLARE)

然后我把这些，连同 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)扩展到其中包含 (BLOCK NIL ...) 的内容，以及(2)如果不是，它是否间接扩展(通过 MACROEXPAND) 到其中包含 (BLOCK NIL ...) 的内容。它显示了宏扩展，以便您可以确保它们不是误报。

结果如下(我剪掉了一些警告信息):

(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))))))))))))

如您所见，其中包括原始问题中列出的所有符号，而没有其他符号。

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

我相当有信心，实际上这些情况都不会使我的结果无效。将“相当有信心”变成“几乎绝对确定”可能意味着将所需的工作量增加一倍:-)。