Hatena::Groupcadr

わだばLisperになる このページをアンテナに追加 RSSフィード

2004 | 12 |
2005 | 01 | 02 | 07 | 10 | 11 |
2006 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2007 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2008 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2009 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2010 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2011 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 11 |

2011-03-25

バッククォート式のSETF

| 20:26 | バッククォート式のSETF - わだばLisperになる を含むブックマーク はてなブックマーク - バッククォート式のSETF - わだばLisperになる

ぼーっと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が定義されているようです。)

ゲスト



トラックバック - http://cadr.g.hatena.ne.jp/g000001/20110325