2011年6月9日木曜日

defclassとdefmethodをいじくる

特定のシンボルを特別扱いして、省略表記として利用できるような defclassとdefmethodを定義してみました。

似たようなネタばかりやっている気がします。

(asdf:load-system :alexandria)

;; セッターとゲッター
(defgeneric get-slot (obj slot))
(defgeneric set-slot (obj slot new))
(defmethod get-slot (obj slot)
(slot-value obj slot))
(defmethod set-slot (obj slot new)
(setf (slot-value obj slot) new))

(defmethod (setf get-slot) (new obj slot)
(set-slot obj slot new))

(defgeneric get-parameter (obj param))
(defgeneric set-parameter (obj param new))
(defmethod (setf get-parameter) (new obj param)
(set-parameter obj param new))

(defmethod get-parameter ((this hash-table) param)
(gethash param this))
(defmethod set-parameter ((this hash-table) param new)
(setf (gethash param this) new))

;; ドット区切り、ドル記号区切りのシンボルを変換するマクロ
(defmacro with-accessor-translation (&body body)
(let ((symbol-list
(remove-duplicates (collect-accessor-symbols body))))
`(symbol-macrolet ,(mapcar #'accessor-symbol->symbol-macrolet-form symbol-list)
,@body)))

(defun accessor-symbol? (sym)
(when (symbolp sym)
(let* ((name (symbol-name sym))
(len (length name)))
(when (> len 2)
(let ((subname (subseq name 1 (1- len))))
(or (find #\. subname)
(find #\$ subname)))))))

(defun collect-accessor-symbols (exp)
(let ((symbols (alexandria:flatten exp)))
(remove-if-not #'accessor-symbol? symbols)))

(defun separate-symbol (sym)
(let ((name (symbol-name sym))
(result nil)
(pos 0))
(loop
:with len = (length name)
:for dot-pos = (position #\. name :start pos)
:for dollar-pos =(position #\$ name :start pos)
:while (< pos len)
:do
(cond
((and (null dot-pos) (null dollar-pos))
(push (subseq name pos) result)
(setf pos len))
((or (null dollar-pos)
(and dot-pos (< dot-pos dollar-pos)))
(push (subseq name pos dot-pos) result)
(push :dot result)
(setf pos (1+ dot-pos)))
(t ; (or (null dot-pos) (< dollar-pos dot-pos))
(push (subseq name pos dollar-pos) result)
(push :dollar result)
(setf pos (1+ dollar-pos)))))
(labels ((recur (rest acc)
(if rest
(destructuring-bind (key sel &rest r) rest
(case key
((:dot) (recur r `(get-slot ,acc ',(intern sel))))
((:dollar) (recur r `(get-parameter ,acc ',(intern sel))))
(t (error "invalid keyword"))))
acc)))
(let ((lst (nreverse result)))
(recur (cdr lst) (intern (car lst)))))))

(defun accessor-symbol->symbol-macrolet-form (sym)
`(,sym ,(separate-symbol sym)))

;;; defclass/defmethod マクロの定義
(defmacro defclass* (name (&rest supers) (&rest clauses) &rest options)
`(progn
(defclass ,name ,supers
,(mapcar
#'expand-clause
clauses)
,@options)
,@(mapcar
#'(lambda (clause) (expand-form-in-clause name clause))
clauses)))

(defmacro defmethod* (name (&rest args) &body body)
`(defmethod ,name (,@args)
(with-accessor-translation
,@body)))

(defun couple (lst)
(loop
:for head on lst by #'cddr
:collect (subseq head 0 2)))

(defun expand-clause (clause)
(let ((name (car clause))
(options (couple (cdr clause))))
(let ((result nil))
(dolist (option options)
(case (first option)
((:initform) (push option result))
((:initarg) (push option result))
(T 'nothing-to-do)))
(unless (find :initarg result :key #'first)
(push
`(:initarg ,(alexandria:make-keyword name))
result))
`(,name
,@(apply #'append (nreverse result))))))


(defun expand-form-in-clause (classname clause)
(let ((name (car clause))
(options (couple (cdr clause))))
(let ((result nil))
(dolist (option options)
(cond
((and (eq (first option) :readonly)
(eq (second option) T))
(push `(defmethod set-slot ((this ,classname) (slot (eql ',name)) new)
(error "readonly slot"))
result))
(T 'nothing-to-do)))
`(progn ,@result))))


;; test

(defclass* <person> ()
((id :initform (error "required") :initarg :id :readonly t)
(name)
(age :initarg :age)))

(defmethod* show ((this <person>))
(format t "~A: ~A (~A)~%"
this.id
this.name
this.age))

(defmethod* correct ((this <person>))
(incf this.age))

(defmethod* invalid ((this <person>))
(setf this.id 3))

(defvar p (make-instance '<person> :id 1 :name "kurohuku" :age 23))
(describe p)

(show p)

(correct p)
(describe p)

(invalid p)


0 件のコメント:

コメントを投稿