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 |

2007-11-23

CLOSチュートリアル (2)

| 20:45 | CLOSチュートリアル (2) - わだばLisperになる を含むブックマーク はてなブックマーク - CLOSチュートリアル (2) - わだばLisperになる

Common Lisp クックブックさんのところのCLOSのチュートリアルで新しい練習問題を見付けたので挑戦!。

問題

CLOSチュートリアル 3.5. スロットより

  • defstruct マクロの実装を探し、CLOSのスロットオプションを一つ以上追加しなさい。

解答

SBCLのマクロを追い掛けてみましたが、どうも既存のマクロに追加するというのはちょっと難しそうなので、defstructをラッピングするdefstruct-plusというマクロを定義してみることにしました。

追加したスロットは、一番簡単そうなところで、:accessorと、:readerの2つです。

(defmacro defstruct-plus (name-and-options &rest slot-descriptions)
  (let ((name (carat name-and-options)))
    `(prog1
	 (defstruct ,name-and-options
	   ,@(mapcar (lambda (x) 
		       (cond ((member :accessor x) (remove-accessor-def x))
			     ((member :reader x) (repl-reader-def x))
			     ('T x)))
		     slot-descriptions))
       ,@(mapcar (lambda (x) 
		   (multiple-value-bind (accessor slot-name reader-p) 
		       (get-accessor-or-reader-name x)
		     (let ((acc-name (symbol-name-conc name "-" slot-name)))
		       (when accessor
			 (if reader-p
			     `(defun ,accessor (obj)
				(,acc-name obj))
			     `(progn
				(defun ,accessor (obj)
				  (,acc-name obj))
				(define-setf-expander ,accessor (obj)
				  (get-setf-expansion 
				 `(,',acc-name ,obj)))))))))
		   slot-descriptions))))

;; defstructには不要な、:accessor引数を除いた引数を返す
(defun remove-accessor-def (args)
  (do ((a args (cdr a)) 
       res)
      ((endp a) (nreverse res))
    (if (eq :accessor (car a))
	(return (nreconc res (cddr a)))
	(push (car a) res))))

;; defstructの形式に合わせて:reader引数を:read-only tに変換する
(defun repl-reader-def (args)
  (do ((a args (cdr a)) 
       res)
      ((endp a) (nreverse res))
    (if (eq :reader (car a))
	(return (nreconc res `(:read-only 'T ,@(cddr a))))
	(push (car a) res))))

;; 関数の名前を付けるための補助関数
(defun symbol-name-conc (&rest names)
  (values
   (intern 
    (string-upcase 
     (apply #'concatenate 'string (mapcar #'string names))))))

(defun carat (obj)
  (if (consp obj) (car obj) obj))

;; :readerか:accessorの場合に与えられた値を返す。
;;  2値目は、スロットの名前
;;  :readerの場合、3値目でtを返す。
(defun get-accessor-or-reader-name (args)
  (let (reader-p)
    (values (or (cadr (member :accessor args))
		(let ((tem (cadr (member :reader args))))
		  (when tem
		    (setq reader-p t)
		    tem)))
	    (car args)
	    reader-p)))

適当に建増しを繰り返していたらどうにも収集がついてない長ったらしいものになってしまいました。

(defstruct-plus foo
  (x 10 :accessor access-foo-x)
  (y 20 :reader reader-foo-y-ro))

(PROG1 (DEFSTRUCT FOO (X 10) (Y 20 :READ-ONLY 'T))
  (PROGN
   (DEFUN ACCESS-FOO-X (OBJ) (FOO-X OBJ))
   (DEFINE-SETF-EXPANDER ACCESS-FOO-X (OBJ)
     (GET-SETF-EXPANSION `(FOO-X ,OBJ))))
  (DEFUN READER-FOO-Y-RO (OBJ) (FOO-Y OBJ)))

のように展開され、普通のdefstructの定義に加えてaccessorかreaderで指定した名前の関数をエイリアスとして作っているような感じです。