Named-Readtables いいね

g000001 さんからいいと聞いていた Named-Readtables をようやく使ってみた。

Common Lisp のリーダマクロはいろいろいろいろだけど。。。 Named-Readtables はいいと思う。

下のコードはいろいろいろいろだけど。。。 Named-Readtables はいいような気がする。

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :named-readtables))

(defpackage :string-reader
  (:use :cl)
  (:export #:syntax))

(defun |#"""-reader"""| (stream)
  #1=(read-char stream t nil t)
  (with-output-to-string (*standard-output*)
    (loop for c1 = #1# then c2
          for c2 = #1# then c3
          for c3 = #1# then #1#
          until (and (char= #\" c1 c2 c3)
                     (char/= #\" (peek-char nil stream nil #\? t)))
          do (write-char c1))))

(defun |#"-reader| (stream sub-char numarg)
  (declare (ignore sub-char numarg))
  (|#"-parser|
   (if (equal #\" (peek-char nil stream t nil t))
       (progn
         (read-char stream)
         (if (equal #\" (peek-char nil stream nil nil t))
             (|#"""-reader"""| stream)
             ""))
       (|#"-reader"| stream))))

(defun |#"-reader"| (stream)
  (funcall (get-macro-character #\") stream #\"))

(defun |#"-parser| (s)
  (macrolet ((peek-equal (c)
               `(equal ,c (peek-char nil in nil nil))))
    (let* ((args nil)
           (format
            (with-output-to-string (out)
              (with-input-from-string (in s)
                (loop for c = #1=(read-char in nil)
                      while c
                      if (and (equal #\# c) (peek-equal #\,))
                        do (progn
                             #1#
                             (write-string "~a" out)
                             (push (read-preserving-whitespace in) args)
                             (when (peek-equal #\,)
                               #1#))
                      ;; 次の2行をコメントアウトするか否か悩ましいところ
                      else if (char= #\~ c)
                             do (write-string "~~" out)
                      else
                        do (write-char c out))))))
      `(format nil ,format ,@(reverse args)))))

(named-readtables:defreadtable string-reader:syntax
  (:merge :common-lisp)
  (:dispatch-macro-char #\# #\" '|#"-reader|))

(named-readtables:in-readtable string-reader:syntax)

(princ #"""Common Lisp のスペシャルオペレータの数は#,(loop for sym being the external-symbol in :common-lisp count (special-operator-p sym))個です。""")

(named-readtables:in-readtable :common-lisp)

ちょっとちゃんと書いて使ってみようかな、という気がしてきた。