pkg-bind再び — #:g1

Posted 2011-06-20 09:28:00 GMT

以前Zetalispのpkg-bindをCLで再現するのに挑戦したことがありました。
-ZetalispのPKG-BIND - 'T - cadr group
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はそれほど使う機会もありませんが、他のパッケージからコピペしたコードをとりあえず手元のパッケージ内で動作確認したい場合などにそれなりに便利に使えます。

comments powered by Disqus