CCASE 在 SBCL 中的意外行为（与 CASE 和 ECASE 相比）

Question

为什么下面示例中的 ecase（或 case）和 ccase 之间存在行为差异？与 ccase 不同，ecase 表现正常。使用 SBCL 版本 2.0.1 进行测试。快速查看规格后，我没有找到解释（CLTL2）。

(ecase 'dos
  ((i uno) 1)
  ((ii dos) 2)
  ((iii tres) 3))

2

(ccase 'dos
  ((i uno) 1)
  ((ii dos) 2)
  ((iii tres) 3))

; in: CCASE 'DOS
;     (SETF 'DOS
;             (SB-KERNEL:CASE-BODY-ERROR 'CCASE ''DOS #:G680
;                                        '(MEMBER I UNO II DOS III TRES)
;                                        '(I UNO II DOS III TRES)))
; --> LET* FUNCALL 
; ==>
;   (SB-C::%FUNCALL #'(SETF QUOTE) #:NEW1 #:DOS3)
; 
; caught WARNING:
;   The function (SETF QUOTE) is undefined, and its name is reserved by ANSI CL so
;   that even if it were defined later, the code doing so would not be portable.

; ==>
;   (LET* ((#:DOS3 DOS)
;          (#:NEW1
;           (SB-KERNEL:CASE-BODY-ERROR 'CCASE ''DOS #:G680
;                                      '(MEMBER I UNO II DOS III TRES)
;                                      '(I UNO II DOS III TRES))))
;     (FUNCALL #'(SETF QUOTE) #:NEW1 #:DOS3))
; 
; caught WARNING:
;   undefined variable: COMMON-LISP-USER::DOS
; 
; compilation unit finished
;   Undefined function:
;     (SETF QUOTE)
;   Undefined variable:
;     DOS
;   caught 2 WARNING conditions
2

Answer 1

ccase

需要一个可以存储值的place，而不是一个值。换句话说，

ccase

的第一个参数必须是

setf

的有效第一个参数的形式。

这是因为，在没有子句匹配的情况下，会通过

store-value

restart 发出可重新启动的错误信号，这将为第一个参数的位置分配一个值，然后重试整个

ccase

表单。

'x

不是这样的形式：你不能说

(setf 'x ...)

。

这是

ccase

的玩具版本，称为

continuable-case

，它演示了

ccase

的扩展可能是什么。这可能会遗漏一些东西。

(defmacro continuable-case (place &body clauses)
  (when (assoc-if (lambda (k) (member k '(otherwise t))) clauses)
    (error "can't have a default clause"))
  (let ((name (make-symbol "CONTINUABLE-CASE"))
        (retry (make-symbol "RETRY"))
        (value (make-symbol "VALUE"))
        (v (make-symbol "V"))
        (expected-type `(member ,@(mapcan (lambda (clause)
                                            (let ((key (first clause)))
                                              (typecase key
                                                (cons
                                                 (copy-list key))
                                                (t (list key)))))
                                          clauses))))
    `(block ,name
       (tagbody
        ,retry
        (return-from ,name
          (let ((,value ,place))
            (case ,value
              ,@clauses
              (otherwise
               (restart-case
                   (error 'type-error
                          :datum ,value
                          :expected-type ',expected-type)
                 (store-value (,v)
                   :report "set a new value and retry"
                   :interactive (lambda ()
                                  (format *query-io* "~&new value: ")
                                  (finish-output *query-io*)
                                  (list (read *query-io*)))
                   (setf ,place ,v)
                   (go ,retry)))))))))))