cutとか

CommonLisp Scheme

Guacheのリファレンスを眺めてたら便利そうなものを見つけた。
Gauche ユーザリファレンス: 4.3 手続きを作る
しかしmacroexpand-1しても良く分からないし、参照実装も殆ど理解できなかったので適当にざっくり書いてみる。

(defun cut-internal (proc exprs-or-slots evaluate)
  (let (slots binds args argr)
    (dolist (e exprs-or-slots)
      (let ((s (gensym)))
        (if evaluate
            (case e
              (<> #1=(push s slots) #2=(push s args))
              (<...> #3=(push '&rest slots) #1# #4=(setf argr s))
              (t (push `(,s ,e) binds) #2#))
            (case e
              (<> #1# #2#)
              (<...> #3# #1# #4#)
              (t (push e args))))))
    `(let ,(reverse binds)
       (lambda (,@(reverse slots))
         (apply #',proc ,@(reverse args) ,argr)))))

(defmacro cut (proc &rest exprs-or-slots)
  (cut-internal proc exprs-or-slots nil))

(defmacro cute (proc &rest exprs-or-slots)
  (cut-internal proc exprs-or-slots t))

このテストは通った。
が、実は最初bindsをreverseし忘れてて、このテストだと影響がなかったので次のコードで追試。

(defmacro check= ((&optional (test 'eql)) &body pairs)
  (flet ((disp (pass? form result correct)
           (format t "~&~:[NG~;OK~]: ~a~%    = ~a~%~:[   /= ~a~%~;~]"
                   pass? form result pass? correct)
           pass?))
    (let ((forms (mapcar #'(lambda (p)
                             `(funcall ,#'disp (,test ,@p) '#1=,(car p) #1# ,(cadr p)))
                         pairs)))
      `(not (some #'null (list ,@forms))))))

(defun chk2 ()
  (check= (equal)
    ((let((a 0))(funcall (cut list a (setq a 1) a <>) a))
     '(0 1 1 0))
    ((let((a 0))(funcall (cut list a (setq a 1) a <> (setq a 2) a <>) a a))
     '(0 1 1 0 2 2 0))
    ((let((a 0))(funcall (cut list a (setq a 1) a <> (setq a 2) a <...>) a (setq a 3) a))
     '(3 1 1 0 2 2 3 3))
    ((let((a 0))(funcall (cute list a (setq a 1) a <>) a))
     '(1 1 0 1))
    ((let((a 0))(funcall (cute list a (setq a 1) a <> (setq a 2) a <>) a a))
     '(1 1 2 1 2 0 1))
    ((let((a 0))(funcall (cute list a (setq a 1) a <> (setq a 2) a <...>) a (setq a 3) a))
     '(1 1 2 0 2 3 3 3))

今後も使えるようにと、PCLを参考に指定した関数でペアを比較するテストマクロを書いてみた。
正解はGaucheで同等のコードを実行した結果から取ってきたんだけど、これを実行すると

OK: (let ((a 0)) (funcall (cut list a (setq a 1) a <>) a))
    = (0 1 1 0)
OK: (let ((a 0)) (funcall (cut list a (setq a 1) a <> (setq a 2) a <>) a a))
    = (0 1 1 0 2 2 0)
OK: (let ((a 0)) (funcall (cut list a (setq a 1) a <> (setq a 2) a <...>) a (setq a 3) a))
    = (3 1 1 0 2 2 3 3)
NG: (let ((a 0)) (funcall (cute list a (setq a 1) a <>) a))
    = (0 1 1 1)
   /= (1 1 0 1)
NG: (let ((a 0)) (funcall (cute list a (setq a 1) a <> (setq a 2) a <>) a a))
    = (0 1 1 2 2 2 2)
   /= (1 1 2 1 2 0 1)
NG: (let ((a 0)) (funcall (cute list a (setq a 1) a <> (setq a 2) a <...>) a (setq a 3) a))
    = (0 1 1 2 2 2 3 3)
   /= (1 1 2 0 2 3 3 3)

cute全滅。なんかreverseし忘れてたコードの結果の方が近い。

OK: (let ((a 0)) (funcall (cute-r list a (setq a 1) a <>) a))
    = (1 1 0 1)
OK: (let ((a 0)) (funcall (cute-r list a (setq a 1) a <> (setq a 2) a <>) a a))
    = (1 1 2 1 2 0 1)
NG: (let ((a 0)) (funcall (cute-r list a (setq a 1) a <> (setq a 2) a <...>) a (setq a 3) a))
    = (1 1 2 1 2 0 3 3)
   /= (1 1 2 0 2 3 3 3)

評価順どうなってんの?と思ってググって見たら分かりやすいページが。
http://karetta.jp/book-node/gauche-hacks/009133

しかしSchemeは引数の評価順は決められてないのか…ということでYpsilonとMzSchemeで試してみたところ、YpsilonはGaucheと同じ結果になりMzSchemeはこの通り上のreverseし忘れ版と同じ結果に。

要するにこんなコード書いちゃダメですよってことですね。

あー

gosh> (map (cut <> 2 3) (list + - * /))
(5 -1 6 2/3)

こんな書き方もできるって書いてある事に今更気づいた。後で直そう。