ロカール関数で (setf READER) を諦めた記録

CL だとこんなことができる。

;; Clozure CL での例
CL-USER> (let ((table (make-hash-table)))
           (labels ((key (key)
                      (gethash key table))
                    ((setf key) (value key)
                      (setf (gethash key table) value)))
             (setf (key 1) "foo"
                   (key 2) "bar")
             (maphash (lambda (k v)
                        (format t "~S -> ~S~%" k v))
                      table)
             (values (key 1) (key 2))))
2 -> "bar"
1 -> "foo"
"foo"
"bar"

(setf (key X) VALUE) を正しく展開できるようにするにはこんなのがあればいい。

(defun |(setf key)| (value key)
  (setf (gethash key table) value))
=> |(setf key)|

(define-setf-method key (&rest sub-forms)
  (values (list '#1=#:args)
          (list `(list ,@sub-forms))
          (list '#2=#:new-value)
          `(apply '|(setf key)| #2# #1#)
          `(apply 'key #2#)))
=> (setf key)

(macroexpand '(setf (key X) VALUE))
=> (let* ((#1=#:args (list X))
          (#2=#:new-value VALUE))
     (apply '|(setf key)| #2# #1#))
=> t

define-setf-method で定義した setf-expander はプロパティ lisp::setf-method にある。

(get 'key 'lisp::setf-method)
=> #<lexical-closure: (anonymous)>

(si:closure-body *)
=> (lambda (#:G225 &rest sub-forms)
     (values (list '#1=#:args)
             (list (cons 'list sub-forms))
             (list '#2=#:new-value)
             '(apply '|(setf key)| #2# #1#)
             '(apply 'key #2#)))

labels の BODY 部分で setf を（macrolet で）置き換えて、展開する時に一時的にプロパティ lisp::setf-method に setf-expander を突っ込んでやる。のだが展開できない。

(remprop 'x 'lisp::setf-method)
=> nil

;; 展開前の式
(let ((table (make-hash-table)))
  (labels ((key (key)
             (gethash key table))
           ((setf key) (value key)
             (setf (gethash key table) value)))
    (setf (key 1) "foo"
          (key 2) "bar")
    (maphash (lambda (k v)
               (format t "~S -> ~S~%" k v))
             table)
    (values (key 1) (key 2))))

;; 手動ででっちあげた展開形
(let ((table (make-hash-table)))
  (labels ((key (key)
             (gethash key table))
           (|(setf key)| (value key)
             (setf (gethash key table) value)))
    (macrolet ((setf (&environment env &rest args)
                 (let ((ovals nil)
                       (expander (lambda (#:env &rest sub-forms)
                                   (values (list '#1=#:args)
                                           (list `(list ,@sub-forms))
                                           (list '#2=#:new-value)
                                           `(apply #'|(setf key)| #2# #1#)
                                           `(apply 'key #2#)))))
                   (unwind-protect
                       (progn
                         (push (cons 'key (get 'key 'lisp::setf-method '#0=#:unbound)) ovals)
                         (si:*putprop 'key expander 'lisp::setf-method)
                         ;; lisp/setf.l より
                         (cond ((endp args) nil)
                               ((endp (cdr args))
                                (error "~S: 不正なsetfフォームです" args))
                               ((endp (cddr args))
                                (lisp::setf-expand-1 (car args) (cadr args) env))
                               (t
                                (cons 'progn (lisp::setf-expand args env)))))
                     (let ((oval (cdr (assoc 'key ovals))))
                       (if (eq oval '#0#)
                         (remprop 'key 'lisp::setf-method)
                         (si:*putprop 'key oval 'lisp::setf-method)))))))
      (setf (key 1) "foo"
            (key 2) "bar")
      (maphash (lambda (k v)
                 (format t "~S -> ~S~%" k v))
               table)
      (values (key 1) (key 2)))))
; Evaluation aborted on `simple-error'
;   (key 1)のsetfメソッドはありません

でどこでエラーになるのか調べたら get-setf-method-multiple-value でローカルな（関数｜マクロ）だったらマクロ展開できなきゃいかん事になってる。

;; lisp/setf.l より
(defun get-setf-method-multiple-value (form &optional env)
  (let (tem)
    (cond
     ; ...(snip)...
     ((si:*find-in-environment form env)
      ;(setq tem (assoc (car form) env))
      (setq tem (macroexpand-1 form env))
      (if (eq tem form)
        (error "~Sのsetfメソッドはありません" form))
      (get-setf-method-multiple-value tem env))
     ; ...(snip)...
     )))

ここまでやって諦めた。

ローカルな setf で展開する時に一時的に get-setf-method-multiple-value の定義を入れ替えてやれば何とかなるような気がするけど、疲れたので記録だけ残して放置。