DO,PROG等在其身体之间建立一个名为nil的隐式块. CLHS不提供执行此操作的所有标准宏的列表.到目前为止,我知道的是：
DO DO* PROG PROG* LOOP DOLIST DOTIMES DO-SYMBOLS DO-ALL-SYMBOLS DO-EXTERNAL-SYMBOLS
有没有其他标准的CL宏或特殊形式建立隐含的零块？
解决方法
我相信这个问题的清单是完整的.我的证据是实验性的,不是来自检查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)是否调用给定的宏产生一个零块可能取决于调用的细节.我故意为所有的宏选择了很好的简单调用,也可能(例如)一些更为巴洛克式的DEFCLASS实例可能会创建一个零块. (2)我可能错过了宏列表中的一些项目. (我的候选人列表是CLISP输出的顺序,但我重新排列了一些相关的宏.)(3)CLISP可能是非标准的相关方式.
我相信,没有一个是无效的结果.将“相当自信”变成“绝对确定”,这可能意味着需要的工作量翻倍:-).
