Hatena::Groupcadr

わだばLisperになる このページをアンテナに追加 RSSフィード

2004 | 12 |
2005 | 01 | 02 | 07 | 10 | 11 |
2006 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2007 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2008 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2009 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2010 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2011 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 11 |

2011-06-20

pkg-bind再び

| 18:28 | pkg-bind再び - わだばLisperになる を含むブックマーク はてなブックマーク - pkg-bind再び - わだばLisperになる

以前Zetalispのpkg-bindをCLで再現するのに挑戦したことがありました。

pkg-bindとはどういうものかというと、囲んだ範囲は指定したパッケージ内にin-packageしたような感じに書けるというものです。

(pkg-bind :drakma
  (let ((fun #'http-request))
    (funcall fun "http://example.com")))

これが、

(LET ((DRAKMA::FUN #'DRAKMA:HTTP-REQUEST))
  (FUNCALL DRAKMA::FUN "http://example.com"))

こんな感じに解釈されます。

前回は中途半端な感じでしたが、通勤途中に前回のアプローチを一捻りする方法を思い付いたのでメモ。

前回は、パッケージ名を含んだ文字列を作成して、それを元にS式を組み立てましたが、今回は、文字列の作成に、PRINT-OBJECTを使ってみます。

具体的には、シンボルを読んで、あるオブジェクトに変換して、そのプリティプリントが、#.(CL:INTERN "FOO" "CL")という風になるようにします。

あとは、ボディを再帰的に走査して、文字列として出力し、READ-FROM-STRINGし、それをDEFMACROのボディとします。

(defclass intern-form ()
  ((name :initarg :name)
   (package :initarg :package)))

(defmethod print-object ((obj intern-form) stream)
  (format stream
          "#.(CL:INTERN ~S ~S)"
          (slot-value obj 'name)
          (slot-value obj 'package)))

(defun up-symbol (elt pkg)
  (typecase elt
    (symbol
       (let ((name (string elt)))
         (make-instance 'intern-form
                  :name name
               :package (package-name
                         (let ((elt-pkg (symbol-package elt)))
                           (cond ((eq elt-pkg (find-package pkg))
                                  pkg)
                                 ;;
                                 ((and (eq elt-pkg (find-package *package*))
                                       (find-symbol (string elt) pkg))
                                  pkg)
                                 ;;
                                 ('T elt-pkg)))))))
    ;;
    (otherwise elt)))

(defun symbol-to-intern-form (tree pkg)
  (cond ((null tree)
         tree)
        ;;
        ((atom (car tree))
         (let ((elt (car tree)))
           (cons (if (eq 'pkg-bind elt)
                     'pkg-bind
                     (up-symbol elt pkg))
                 (symbol-to-intern-form (cdr tree) pkg))))
        ;;
        ('T (cons (symbol-to-intern-form (car tree) pkg)
                  (symbol-to-intern-form (cdr tree) pkg)))))

(defmacro pkg-bind (pkg &body body)
  `(progn
     ,@(read-from-string
        (write-to-string
         (symbol-to-intern-form body (package-name pkg))))))

pkg-bindはそれほど使う機会もありませんが、他のパッケージからコピペしたコードをとりあえず手元のパッケージ内で動作確認したい場合などにそれなりに便利に使えます。