Common Lisp のリーダ・マクロであれこれ

リーダ・マクロの練習。全体的に Clojure を意識してみました。
ブレース（{}）は普通の丸括弧と同じ。
#{} はハッシュテーブルを作る。シャープとブレースの間に数を入れるとテスト関数を指定できる。
ブラケット（[]）はベクタを作る。引数は評価されないので #() と同じ。
$ は続く２つのオブジェクトを取り込み、２番目がベクタなら１番目を配列と見なしてアクセス。２番目がリストなら、１番目はハッシュテーブル扱い。後者の場合は gethash に渡している関係で、キーのほうが先に評価されてしまう。要注意
#_ は次に来る式を読み飛ばす。あるいはシャープとバーの間に与えられた数のぶんだけスキップ。
#> は次に来る式を print に渡す。print は受け取ったオブジェクトをそのまま値として返すので、読み飛ばしは起こらない。ただしこれも #_ と同じで、引数を与えるとそのぶんだけ読んで印字する。その場合、最後の値だけが返却される。
最後に、fn は匿名関数を作るマクロ。引数リストの位置にベクタを受け取る。

(defun user-read-left-brace (stream char)
  (declare (ignore char))
  (read-delimited-list #\} stream t))

(set-macro-character #\{ #'user-read-left-brace)

(set-macro-character #\} (get-macro-character #\) nil))



(defun user-sharp-left-brace (stream char num)
  (declare (ignore char))
  (let ((g (gensym)))
    `(let ((,g (make-hash-table :test ,(case num
                                             (0 '#'eq)
                                             (1 '#'eql)
                                             (2 '#'equal)
                                             (3 '#'equalp)
                                             (t '#'eql)))))
       (setf ,@(do ((lst (read-delimited-list #\} stream t)
                         (cddr lst))
                    (acc nil))
                   ((null lst) (nreverse acc))
                   (push `(gethash ,(car lst) ,g) acc)
                   (push (cadr lst) acc)))
       ,g)))

(set-dispatch-macro-character #\# #\{ #'user-sharp-left-brace)



(defun user-read-left-bracket (stream char)
  (declare (ignore char))
  (coerce (read-delimited-list #\] stream t)
          'vector))

(set-macro-character #\[ #'user-read-left-bracket)

(set-macro-character #\] (get-macro-character #\) nil))



(defun user-read-dollar (stream char)
  (declare (ignore char))
  (let ((var (read stream t nil t))
        (arg (read stream t nil t)))
    (etypecase arg
      (vector `(aref ,var ,@(coerce arg 'list)))
      (list   `(gethash ,(car arg) ,var)))))

(set-macro-character #\$ #'user-read-dollar)



(defun user-sharp-underbar (stream char num)
  (declare (ignore char))
  (if num
      (dotimes (i num) (read stream t nil t))
      (read stream t nil t))
  (read stream t nil t))

(set-dispatch-macro-character #\# #\_ #'user-sharp-underbar)



(defun user-sharp-greater-than (stream char num)
  (declare (ignore char))
  (if num
      (let (form)
        (dotimes (i num form)
          (setq form (print (read stream t nil t)))))
      (print (read stream t nil t))))

(set-dispatch-macro-character #\# #\> #'user-sharp-greater-than)



(defmacro fn (argv &body body)
  `#'(lambda ,(coerce argv 'list) ,@body))

使用例：

CL-USER> (print '{a b c})

(A B C) 
(A B C)
CL-USER> (setq v [a b c])
#(A B C)
CL-USER> $v[2]
C
CL-USER> (setq ht #0{'one 1 'two 2})
#<EQ hash-table with 2 entries @ #x2083db22>
CL-USER> $ht{'two}
2
T
CL-USER> (funcall (fn [x &rest y] (list x y))
                  1 2 3)
(1 (2 3))