プログラミング Gauche の object マクロと LOL の dlambda マクロ

プログラミング Gauche をパラパラ読んでたら、P.270 に object というマクロ（syntax-rules）が載ってたんですね。よく見たら、どこかで見たこのあるような形と機能だなーと。LOL（LET OVER LAMBDA Edition 1.0）の dlambda にそっくりなんですね。

dlambda はもともと Common Lisp の伝統的なマクロで書かれているので、見た目は object マクロとは似ていません。ですが、dlambda を scheme の衛生的マクロで書くとそっくりです。（似たような機能なのでそりゃそうなんですが）

• vallog: syntax-rules: dlambda

以前書いた衛生的マクロ版 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)
;; -> 1
(counter 'inc)
;; -> 2
(counter 'dec 10)
;; -> -6

で、これが プログラミング 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)
;; -> 1
(counter 'inc 10)
;; -> 11
(counter 'dec)
;; -> 10

メソッド名はキーワードでも良いかも。こんな風に。

(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)
;; -> 3
(counter :inc 1)
;; -> 4

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))))