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)