バッククォート式のSETF — #:g1

Posted 2011-03-25 11:26:00 GMT

ぼーっとCADR LispマシンのSystem 99(割と後期のバージョンで80年代中期?)のソースを眺めていたのですが、SETF関係の定義のところで見慣れないものをみつけました。

;;;  CADR System 99 sys2;setf.lisp.1

;;; Handle SETF of backquote expressions, for decomposition. ;;; For example, (SETF `(A ,B (D ,XYZ)) FOO) ;;; sets B to the CADR and XYZ to the CADADDR of FOO. ;;; The constants in the pattern are ignored.

;;; Backquotes which use ,@ or ,. other than at the end of a list ;;; expand into APPENDs or NCONCs and cannot be SETF'd.

;;; This was used for making (setf `(a ,b) foo) return t if ;;; foo matched the pattern (had A as its car). ;;; The other change for reinstalling this ;;; would be to replace the PROGNs with ANDs ;;; in the expansions produced by (LIST SETF), etc. ;;;(DEFUN SETF-MATCH (PATTERN OBJECT) ;;; (COND ((NULL PATTERN) T) ;;; ((SYMBOLP PATTERN) ;;; `(PROGN (SETQ ,PATTERN ,OBJECT) T)) ;;; ((EQ (CAR PATTERN) 'QUOTE) ;;; `(EQUAL ,PATTERN ,OBJECT)) ;;; ((MEMQ (CAR PATTERN) ;;; '(CONS LIST LIST*)) ;;; `(SETF ,PATTERN ,OBJECT)) ;;; (T `(PROGN (SETF ,PATTERN ,OBJECT) T))))

(SETF `(A ,B (D ,XYZ)) FOO)というのはこれ如何に、何やら面白そう、ということでソースをCommon Lispで動くように少し修正して動かしてみたところ
(let ((foo (list 1 2 (list (list 3) 4 5)))
      a b c d e f)
  (setf `(,a ,b ((,c) ,d ,e)) foo)
  (list a b c d e))
;=> (1 2 3 4 5)
のようなことができるようです。これは便利そう。
上の式は、
(LET ((FOO (LIST 1 2 (LIST (LIST 3) 4 5))) A B C D E F)
  (MULTIPLE-VALUE-BIND (|g2543|)
                       FOO
    (PROGN
      (SETQ A (NTH 0 |g2543|))
      (SETQ B (NTH 1 |g2543|))
      (LET* ()
        (MULTIPLE-VALUE-BIND (|g2544|)
                             (NTH 2 |g2543|)
          (PROGN
            (LET* ()
              (MULTIPLE-VALUE-BIND (|g2545|)
                                   (NTH 0 |g2544|)
                (PROGN (SETQ C (NTH 0 |g2545|)))))
            (SETQ D (NTH 1 |g2544|))
            (SETQ E (NTH 2 |g2544|)))))))
  (list a b c d e))
;=> (1 2 3 4 5)
のように展開されます。

以下、ANSI CLで動くようにしたもの (SBCLのみ対応)
#+sbcl (import 'sb-ext:without-package-locks)

(defun car-safe (form) (if (consp form) (car form) form))

(defun setf-match (pattern object) (cond ((eq (car-safe pattern) 'quote) nil) (t `(setf ,pattern ,object))))

(without-package-locks (define-setf-expander list (&rest elts) (let ((storevar (gensym))) (values nil nil (list storevar) (do ((i 0 (1+ i)) (accum) (args elts (cdr args))) ((null args) (cons 'progn (nreverse accum))) (push (setf-match (car args) `(nth ,i ,storevar)) accum)) `(incorrect-structure-setf list . ,elts)))))

#+sbcl (without-package-locks (define-setf-expander sb-impl::backq-list (&rest elts) (let ((storevar (gensym))) (values nil nil (list storevar) (do ((i 0 (1+ i)) (accum) (args elts (cdr args))) ((null args) (cons 'progn (nreverse accum))) (push (setf-match (car args) `(nth ,i ,storevar)) accum)) `(incorrect-structure-setf list . ,elts)))))

(without-package-locks (define-setf-expander list* (&rest elts) (let ((storevar (gensym))) (values nil nil (list storevar) (do ((i 0 (1+ i)) (accum) (args elts (cdr args))) ((null args) (cons 'progn (nreverse accum))) (cond ((cdr args) (push (setf-match (car args) `(nth ,i ,storevar)) accum)) (t (push (setf-match (car args) `(nthcdr ,i ,storevar)) accum)))) `(incorrect-structure-setf list* . ,elts)))))

#+sbcl (without-package-locks (define-setf-expander sb-impl::backq-list* (&rest elts) (let ((storevar (gensym))) (values nil nil (list storevar) (do ((i 0 (1+ i)) (accum) (args elts (cdr args))) ((null args) (cons 'progn (nreverse accum))) (cond ((cdr args) (push (setf-match (car args) `(nth ,i ,storevar)) accum)) (t (push (setf-match (car args) `(nthcdr ,i ,storevar)) accum)))) `(incorrect-structure-setf list* . ,elts)))))

(without-package-locks (define-setf-expander cons (car cdr) (let ((storevar (gensym))) (values nil nil (list storevar) `(progn ,(setf-match car `(car ,storevar)) ,(setf-match cdr `(cdr ,storevar))) `(incorrect-structure-setf cons ,car ,cdr)))))

#+sbcl (without-package-locks (define-setf-expander sb-impl::backq-cons (car cdr) (let ((storevar (gensym))) (values nil nil (list storevar) `(progn ,(setf-match car `(car ,storevar)) ,(setf-match cdr `(cdr ,storevar))) `(incorrect-structure-setf cons ,car ,cdr)))))

(defmacro incorrect-structure-setf (&rest args) (error "You cannot SETF the place ~S~% in a way that refers to its old contents." args))

CADRでは、listや、list*にしかSETFは定義されていませんが、SBCLの場合は、リーダーマクロはBACKQ-LIST等に展開されるので、そちらも対処。
SETFが再帰的に展開されるというのも面白いですが、なによりバッククォート式やリストにSETFを定義するという発想が素晴しいですね。
他には、LETやPROGNなどのSETFも定義されています。 (ちなみに、CLISPでは、IFなどにもSETFが定義されているようです。)

comments powered by Disqus