プログラミング Gauche をパラパラ読んでたら、P.270 に object というマクロ（syntax-rules）が載ってたんですね。よく見たら、どこかで見たこのあるような形と機能だなーと。LOL（
LET OVER LAMBDA Edition 1.0）の dlambda にそっくりなんですね。
dlambda はもともと Common Lisp の伝統的なマクロで書かれているので、見た目は object マクロとは似ていません。ですが、dlambda を scheme の衛生的マクロで書くとそっくりです。（似たような機能なのでそりゃそうなんですが）
以前書いた衛生的マクロ版 dlambda をちょっと書き直して再掲するとこんなの。
(define-syntax dlambda
(syntax-rules (else)
((_ (msg (arg ...) body ...) ...)
(^ (key . args)
(case key
((msg)(apply (^ (arg ...)
body ...) args))
...
(else key))
))))
使い方はこんな感じ。
(define counter
(let1 count 0
(dlambda
(inc (:optional (n 1))(inc! count n))
(dec (:optional (n 1))(dec! count n)))))
(counter 'inc)
(counter 'inc)
(counter 'dec 10)
で、これが
プログラミング Gauche に載ってる object マクロ。(P.270)
(define-syntax object
(syntax-rules ()
[(object (ivar ...) (method (arg ...) body ...) ...)
(lambda (ivar ...)
(lambda (message . args)
(case message
[(method) (apply (lambda (arg ...) body ...) args)]
...)))]
))
で、こんな感じでオブジェクトっぽいものを作るのに使える。
(define make-count
(let1 count 0
(object ()
(inc (:optional (n 1))(inc! count n))
(dec (:optional (n 1))(dec! count n)))))
(define counter (make-count))
(counter 'inc)
(counter 'inc 10)
(counter 'dec)
メソッド名はキーワードでも良いかも。こんな風に。
(define make-count
(let1 count 0
(object (:optional step)
(:inc (:optional (n step))(inc! count n))
(:dec (:optional (n step))(dec! count n)))))
(define counter (make-count 3))
(counter :inc)
(counter :inc 1)
object マクロの方が初期値を取れる分良いかも。
プログラミング Gauche を読んでたら object マクロが目にとまりました -> LOL の dlambda に似てるなー -> ただそれだけです。
ついでに
LOL に載ってる Common Lisp 版の dlambda 。
(defmacro! dlambda (&rest ds)
`(lambda (&rest ,g!args)
(case (car ,g!args)
,@(mapcar
(lambda (d)
`(,(if (eq t (car d))
t
(list (car d)))
(apply (lambda ,@(cdr d))
,(if (eq t (car d))
g!args
`(cdr ,g!args)))))
ds))))
LOL の dlambda には defmacro! が必要なので、実際に使うには以下のようになる。伝統的マクロは確かに強力だけど、syntax-rules だと簡単に書けるものもあるので、syntax-rules も結構よくね？
(defun flatten (x)
(labels ((rec (x acc)
(cond ((null x) acc)
((atom x) (cons x acc))
(t (rec
(car x)
(rec (cdr x) acc))))))
(rec x nil)))
(defun mkstr (&rest args)
(with-output-to-string (s)
(dolist (a args) (princ a s))))
(defun symb (&rest args)
(values (intern (apply #'mkstr args))))
(defun g!-symbol-p (s)
(and (symbolp s)
(> (length (symbol-name s)) 2)
(string= (symbol-name s)
"G!"
:start1 0
:end1 2)))
(defmacro defmacro/g! (name args &rest body)
(let ((syms (remove-duplicates
(remove-if-not #'g!-symbol-p
(flatten body)))))
`(defmacro ,name ,args
(let ,(mapcar
(lambda (s)
`(,s (gensym ,(subseq
(symbol-name s)
2))))
syms)
,@body))))
(defun o!-symbol-p (s)
(and (symbolp s)
(> (length (symbol-name s)) 2)
(string= (symbol-name s)
"O!"
:start1 0
:end1 2)))
(defun o!-symbol-to-g!-symbol (s)
(symb "G!"
(subseq (symbol-name s) 2)))
(defmacro defmacro! (name args &rest body)
(let* ((os (remove-if-not #'o!-symbol-p args))
(gs (mapcar #'o!-symbol-to-g!-symbol os)))
`(defmacro/g! ,name ,args
`(let ,(mapcar #'list (list ,@gs) (list ,@os))
,(progn ,@body)))))
(defmacro! dlambda (&rest ds)
`(lambda (&rest ,g!args)
(case (car ,g!args)
,@(mapcar
(lambda (d)
`(,(if (eq t (car d))
t
(list (car d)))
(apply (lambda ,@(cdr d))
,(if (eq t (car d))
g!args
`(cdr ,g!args)))))
ds))))
