如何使 setf-able 成为一个宏，该宏将返回一个返回参数的表单或一个返回默认数字的表单

Question

我有这个宏

(defmacro get-priority (todo)
  `(or (and (listp (car ,todo))
           (cdr (assoc 'priority ,todo)))
      0))

像这样叫

CL-USER> (get-priority '(Make stack overflow question))
0
CL-USER> (get-priority '((priority . 10)(Make stack overflow question)))
10

我需要能够设置 get-priority. 在调用宏结果返回默认0的情况下，我只想设置一个临时位置。也许使用 gensym 可以解决我的问题。

附注。这是我的第一个 CL 宏。

Answer 1

在大多数情况下，基本上有两种现有方法可以很好地工作：改变容器（如哈希表）或操作不可变数据（如关联列表）。您要做的是改变关联列表，这使得正确实现有点困难，并且与预期用途背道而驰。但是，仍然可以编写宏，如下所示。

哈希表

如果你要修改属性，你可以简单地使用哈希表：

(gethash 'priority environment 0)
=> Either the current priority, or zero if no priority is set

(setf (gethash 'priority environment) 10)
=> Replaces priority

甚至：

(incf (gethash 'priority environment 0))
=> Increment current priority (which defaults to zero)

见MAKE-HASH-TABLE和GETHASH。

关联列表

当您想快速从其他环境继承值时，可以认为关联列表优于哈希表。ASSOC工作方式是在列表中查找第一个匹配项，这意味着您可以多次出现priority，其中第一个会遮蔽其他。

(defun increase-priority (environment value)
  (acons 'priority 
         (+ (or (cdr (assoc 'priority env)) 0)
            value)
         environment))

见ACONS。

以上，现有环境没有修改。在前一个的基础上构建了一个新的。它们都共享相同的子列表。假设您有一个名为的函数process，它接受一个值和一个环境，并且env已经绑定到一个环境，您可以调用：

 (process value (increase-priority env 1))

中间环境仅在函数调用内部可见，而env保持不变。如果您复制现有的哈希表或注意撤消临时更改，您可以设法对哈希表执行相同的操作。

修改地点

您通常不想修改关联列表：与哈希表不同，您没有可以轻松更改的单个容器。空关联列表是符号nil：您不能改变该空列表以添加新元素。绕过这个问题的一种可能方法是保留一个结构来保存关联列表的头部（这是下一节所做的）。另一种方法是使用宏，它可以接受表示绑定的未评估表达式，更一般地说是一个地方：如果一个变量env持有一个 nil 关联列表，你想要设置env到新列表。此外，如您的示例所示，您可能会改变常量数据：您引用了您的列表，这在 Common Lisp 中意味着数据应被视为常量；但是随后您尝试修改它，它具有未定义的行为。

就像PUSH，您的宏可以设置保存正在修改的列表的位置。您可以使用 定义自己的宏DEFINE-SETF-EXPANDER，如评论中所述：

(define-setf-expander get-priority (list)
  (let ((current (gensym))
        (new-priority (gensym)))
    (values (list current)
            (list `(assoc 'priority ,list))
            (list new-priority)
            `(prog1 ,new-priority
               (if ,current
                   (setf (cdr ,current) ,new-priority)
                   (setf ,list
                         (list* (cons 'priority ,new-priority)
                                ,list))))
            `(if ,current (cdr ,current) 0)))) 

基本上，我们取现有的利弊细胞，其中'priority在car位置，并替换它cdr。但是如果我们没有找到这样的 cons 单元，我们会在现有列表前面推送一个新的 cons 单元。无论哪种方式，代码都必须返回新的优先级（这是 合同的一部分SETF）。下面是一个例子：

(let ((list ()))
  (print list)
  (print (setf (get-priority list) 10))
  (print list)
  (print (setf (get-priority list) 20))
  (print list)
  (values))

上面的打印：

NIL 
10 
((PRIORITY . 10)) 
20 
((PRIORITY . 20))

这是(setf (get-priority list) 20)（在 SBCL 下）的宏扩展：

(LET* ((#:G757 (ASSOC 'PRIORITY LIST)) (#:G758 20))
  (PROG1 #:G758
    (IF #:G757
        (SETF (CDR #:G757) #:G758)
        (SETF LIST (LIST* (CONS 'PRIORITY #:G758) LIST)))))

当get-priority通过修改其现有值来设置时，将使用 setf-expander 返回的最后一个值。例如，以下表达式：

(let ((list (list)))
  (incf (get-priority list)))

宏展开为：

(LET ((LIST (LIST)))
  (LET* ((#:G771 (ASSOC 'PRIORITY LIST))
         (#:G772
          (+ 1
             (IF #:G771
                 (CDR #:G771)
                 0))))
    (LET ((#:G773 #:G772))
      (IF #:G771
          (SB-KERNEL:%RPLACD #:G771 #:G772)
          (SETQ LIST (LIST* (CONS 'PRIORITY #:G772) LIST)))
      #:G773)))

您可以看到该变量#:G772是从当前值计算的新值，该值要么是从 cons 单元格中提取的，要么默认为零。请注意，扩展也适用于更复杂的地方：

(let ((hash (make-hash-table)))
  (setf (gethash 'cons hash) (cons (list (cons 'priority 0)) :dummy))
  (setf (get-priority (car (gethash 'cons hash))) 100)
  (maphash (lambda (k v) (print v)) hash))

=> (((PRIORITY . 100)) . :DUMMY)

宏展开：

(LET* ((#:G759 (ASSOC 'PRIORITY (CAR (GETHASH 'CONS HASH)))) (#:G760 100))
  (LET ((#:G761 #:G760))
    (IF #:G759
        (SB-KERNEL:%RPLACD #:G759 #:G760)
        (SB-KERNEL:%RPLACA (GETHASH 'CONS HASH) (LIST* (CONS 'PRIORITY #:G760) (CAR (GETHASH 'CONS HASH)))))
    #:G761))

不建议您使用上述 setf 扩展。无论如何，如果您编写宏，请注意不需要的多重评估：您的代码评估todo两次。相反，使用GENSYM来定义局部变量，这些变量包含您只想评估一次的表单值（或者，请参阅有趣的ONCE-ONLY宏）。

专用容器

除了宏，您还可以将列表（nil 或 cons-cell）包装到容器中：

(defstruct (association-list
            (:constructor alist (&optional head))
            (:conc-name alist-))
  head)

然后，您可以head根据需要更改插槽。

(defun aget (alist property &optional default)
  (etypecase alist
    (null default)
    (cons (let ((result (assoc property alist)))
            (if result
                (values (cdr result) result)
                default)))
    (association-list
     (aget (alist-head alist) property default))))

(defmacro apush (key value alist)
  `(push (cons ,key ,value) (alist-head ,alist)))

(defun (setf aget) (value alist property)
  (let ((existing (assoc property (alist-head alist))))
    (prog1 value
      (if existing
          (setf (cdr existing) value)
          (apush property value alist)))))

例如：

(let ((alist (alist)))
  (print (aget alist 'priority 0))
  (print (setf (aget alist 'priority) 10))
  (print alist)
  (print (setf (aget alist 'priority) 20))
  (print alist)
  (values))

... 印刷：

0 
10 
#S(ASSOCIATION-LIST :HEAD ((PRIORITY . 10))) 
20 
#S(ASSOCIATION-LIST :HEAD ((PRIORITY . 20)))

但是，您可能还需要实现额外的辅助函数，这在关联列表方面有点不习惯。更喜欢以不变的方式使用它们。