Onlisp

11章「古典的なマクロ」

コンテキストの生成
  • when-bind*じゃなくて when-let*でいいんじゃないだろうか。
(defmacro when-let* (binds &body body)
  (if (null binds)
      `(progn ,@body)
      `(let (,(car binds))
         (and ,(caar binds)
              (when-let* ,(cdr binds) ,@body)))))
  • あった場合のみ次の計算をしていくというのはよくある処理なので使える。
(defun mappend (fn &rest lsts)
  (apply #'append (apply #'mapcar fn lsts)))

(defmacro condlet (clauses &body body)
  (let ((bodfn (gensym))
        (vars (mapcar #'(lambda (v) (cons v (gensym)))
                      (remove-duplicates
                       (mapcar #'car
                               (mappend #'cdr clauses))))))
    `(labels ((,bodfn ,(mapcar #'car vars)
                      ,@body))
       (cond ,@(mapcar #'(lambda (cl)
                            (condlet-clause vars cl bodfn))
                        clauses)))))

(defun condlet-clause (vars cl bodfn)
  `(,(car cl) (let ,(mapcar #'cdr vars)
                (declare (ignorable ,@(mapcar #'cdr vars)))
                (let ,(condlet-binds vars cl)
                  (,bodfn ,@(mapcar #'cdr vars))))))


(defun condlet-binds (vars cl)
  (mapcar #'(lambda (bindform)
              (if (consp bindform)
                  (cons (cdr (assoc (car bindform) vars))
                        (cdr bindform))))
          (cdr cl)))
  • これも使えるけど、condlet-clauseに(declare (ignorable))がないと警告がでてしまうので追加した。
with系マクロ
  • with系マクロが複雑になるにつれ、マクロと関数の組み合わせが有効となる。
  • ほかの関数に引数としてわたるときも、dynamic-extentは有効なのだろうか??
  • inや>caseなどは使えないと思う。
反復
(defmacro forever (&body body)
  `(do ()
     (nil)
     ,@body))

(defmacro while (test &body body)
  `(do ()
     ((not ,test))
     ,@body))

(defmacro till (test &body body)
  `(do ()
     (,test)
     ,@body))

(defmacro for ((var start stop) &body body)
  (let ((gstop (gensym)))
    `(do ((,var ,start (1+ ,var))
          (,gstop ,stop))
       ((> ,var ,gstop))
       ,@body)))
  • これらは便利だ。
  • do-tuples/oとdo-tuples/cもすごく便利だ。
    • map0-nとかが使われていると汎用じゃないので汎用のloopマクロで書き直した。
(defmacro do-tuples/o (parms source &body body)
  (if parms
      (let ((src (gensym)))
        `(prog ((,src ,source))
            (mapc #'(lambda ,parms ,@body)
                  ,@(loop for i from 0 to (1- (length parms)) collecting
                         `(nthcdr ,i ,src)))))))

(defun dt-args (len rest src)
  (loop for i from 0 to (- len 2) collecting
       (loop for j from 1 to len
          collecting (let ((x (+ i j)))
                       (if (>= x len)
                           `(nth ,(- x len) ,src)
                           `(nth ,(1- x) ,rest))))))

(defmacro do-tuples/c (parms source &body body)
  (if parms
      (with-gensyms (src rest bodfn)
        (let ((len (length parms)))
          `(let ((,src ,source))
             (when (nthcdr ,(1- len) ,src)
               (labels ((,bodfn ,parms ,@body))
                 (do ((,rest ,src (cdr ,rest)))
                     ((not (nthcdr ,(1- len) ,rest))
                      ,@(mapcar #'(lambda (args)
                                    `(,bodfn ,@args))
                                (dt-args len rest src))
                      nil)
                   (,bodfn ,@(loop for i from 1 to len collect
                                  `(nth ,(1- i) ,rest)))))))))))
  • mvdo*とmvdoの利用価値は微妙だが、mvpsetqはあるといい。
(defun shuffle (x y)
  (cond ((null x) y)
        ((null y) x)
        (t (list* (car x) (car y)
                  (shuffle (cdr x) (cdr y))))))

(defmacro mvpsetq (&rest var-form-pairs)
  (let* ((pairs (group var-form-pairs 2))
         (syms (mapcar #'(lambda (p)
                           (mapcar #'(lambda (x)
                                       (declare (ignore x))
                                       (gensym))
                                   (mklist (car p))))
                       pairs)))
    (labels ((rec (ps ss)
               (if (null ps)
                   `(setq
                     ,@(mapcan #'(lambda (p s)
                                   (shuffle (mklist (car p))
                                            s))
                               pairs syms))
                   (let ((body (rec (cdr ps) (cdr ss))))
                     (let ((var/s (caar ps))
                           (expr (cadar ps)))
                       (if (consp var/s)
                           `(multiple-value-bind ,(car ss)
                                ,expr
                              ,body)
                           `(let ((,@(car ss) ,expr))
                              ,body)))))))
      (rec pairs syms))))
  • しかし、こうなるとmvsetqもいるだろう。
    • なぜならsetqは連続して指定できるが、multiple-value-setqは連続して指定できないからである。
(defmacro mvsetq (&rest var-form-pairs)
  `(progn
     ,@(loop for i from 0 to (1- (length var-form-pairs)) by 2 collect
            `(multiple-value-setq ,(nth i var-form-pairs) ,(nth (1+ i) var-form-pairs)))))
  • これでsetqとpsetqの関係と対等になった。
> (let ((w 0) (x 1) (y 2) (z 3))
    (mvsetq (w x) (values 'a 'b) (y z) (values w x))
    (list w x y z))
(A B A B)
> (let ((w 0) (x 1) (y 2) (z 3))
    (mvpsetq (w x) (values 'a 'b) (y z) (values w x))
    (list w x y z))
(A B 0 1)