my-defstruct

Emacs で (require 'cl) とすると defstruct が使えるようになります。ちょっと調べてみました。

• 大きなマクロで理解するのは困難
• Common Lisp の defstruct なので、getter はあるが、setter がない

という訳で、自分で実装してみました。

(defun my-keyword-number-pair (spec)
  (let ((len (length spec)) key ret)
    (dotimes (i len (nreverse ret))
      (setq key (intern (concat ":" (symbol-name (car spec)))))
      (setq ret (cons (cons key i) ret))
      (setq spec (cdr spec)))))

(defmacro my-defstruct (type &rest spec)
  `(progn
     (my-defstruct-constructor ,type ,@spec)
     (my-defstruct-s/getter ,type ,@spec)))

(defmacro my-defstruct-constructor (type &rest spec)
  `(defun ,(intern (concat "my-make-" (symbol-name type))) (&rest args)
     (let* ((alist (quote ,(my-keyword-number-pair spec)))
	    (struct (make-list (length alist) nil))
	    key val key-num)
       (while args
	 (setq key  (car args))
	 (setq args (cdr args))
	 (setq val  (car args))
	 (setq args (cdr args))
	 (unless (keywordp key)
	   (error "'%s' is not a keyword" key))
	 (setq key-num (assoc key alist))
	 (if key-num
	     (setcar (nthcdr (cdr key-num) struct) val)
	   (error "'%s' is unknown" key)))
       struct)))

(defmacro my-defstruct-s/getter (type &rest spec)
  `(let* ((type-name (symbol-name ',type))
	  (keys ',spec)
	  (len (length keys))
	  member-name setter getter)
     (dotimes (i len)
       (setq member-name (symbol-name (car keys)))
       (setq setter (intern (format "my-%s-set-%s" type-name member-name)))
       (fset setter (list 'lambda '(struct value) (list 'setcar (list 'nthcdr i 'struct) 'value) 'struct))
       (setq getter (intern (format "my-%s-get-%s" type-name member-name)))
       (fset getter (list 'lambda '(struct) (list 'nth i 'struct)))
       (setq keys (cdr keys)))))

使い方は、こんな感じです。

(my-defstruct person name age)
(setq taro (my-make-person :name "Taro" :age 20))
;; => ("Taro" 20)
(my-person-get-name taro)
;; => "Taro"
(my-person-set-age taro 21)
;; => ("Taro" 21)

木構造のサンプルとして、括弧付きの二項演算を逆ポーランド記法に書き直すプログラムを書いてみました。

(my-defstruct node value left right)

(defun my-parse-expression (exp)
  (cond
   ((null exp) nil)
   ((atom exp)
    (my-make-node :value exp))
   (t
    (my-make-node :value (nth 1 exp)
		  :left  (my-parse-expression (nth 0 exp))
		  :right (my-parse-expression (nth 2 exp))))))

(defun my-postorder (node)
  (cond
   ((null node) nil)
   (t
    (nconc (my-postorder (my-node-get-left node))
           (my-postorder (my-node-get-right node))
           (list (my-node-get-value node))))))

(setq my-root (my-parse-expression '(1 + (4 / 2))))
;; => (+ (1 nil nil) (/ (4 nil nil) (2 nil nil)))

(my-postorder my-root)
;; => (1 4 2 / +)