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

2011-03-25

バッククォート式のSETF

| 20:26 | バッククォート式のSETF - わだばLisperになる を含むブックマーク はてなブックマーク - バッククォート式のSETF - わだばLisperになる

ぼーっとCADR LispマシンのSystem 99(割と後期のバージョンで80年代中期?)のソースを眺めていたのですが、SETF関係の定義のところで見慣れないものをみつけました。

;;;  CADR System 99 sys2;setf.lisp.1

;;; Handle SETF of backquote expressions, for decomposition.
;;; For example, (SETF `(A ,B (D ,XYZ)) FOO)
;;; sets B to the CADR and XYZ to the CADADDR of FOO.
;;; The constants in the pattern are ignored.

;;; Backquotes which use ,@ or ,. other than at the end of a list
;;; expand into APPENDs or NCONCs and cannot be SETF'd.

;;; This was used for making (setf `(a ,b) foo) return t if
;;; foo matched the pattern (had A as its car).
;;; The other change for reinstalling this
;;; would be to replace the PROGNs with ANDs
;;; in the expansions produced by (LIST SETF), etc.
;;;(DEFUN SETF-MATCH (PATTERN OBJECT)
;;;  (COND ((NULL PATTERN) T)
;;;	((SYMBOLP PATTERN)
;;;	 `(PROGN (SETQ ,PATTERN ,OBJECT) T))
;;;	((EQ (CAR PATTERN) 'QUOTE)
;;;	 `(EQUAL ,PATTERN ,OBJECT))
;;;	((MEMQ (CAR PATTERN)
;;;	       '(CONS LIST LIST*))
;;;	 `(SETF ,PATTERN ,OBJECT))
;;;	(T `(PROGN (SETF ,PATTERN ,OBJECT) T))))

(SETF `(A ,B (D ,XYZ)) FOO)というのはこれ如何に、何やら面白そう、ということでソースをCommon Lispで動くように少し修正して動かしてみたところ

(let ((foo (list 1 2 (list (list 3) 4 5)))
      a b c d e f)
  (setf `(,a ,b ((,c) ,d ,e)) foo)
  (list a b c d e))
;=> (1 2 3 4 5)

のようなことができるようです。これは便利そう。

上の式は、

(LET ((FOO (LIST 1 2 (LIST (LIST 3) 4 5))) A B C D E F)
  (MULTIPLE-VALUE-BIND (|g2543|)
                       FOO
    (PROGN
      (SETQ A (NTH 0 |g2543|))
      (SETQ B (NTH 1 |g2543|))
      (LET* ()
        (MULTIPLE-VALUE-BIND (|g2544|)
                             (NTH 2 |g2543|)
          (PROGN
            (LET* ()
              (MULTIPLE-VALUE-BIND (|g2545|)
                                   (NTH 0 |g2544|)
                (PROGN (SETQ C (NTH 0 |g2545|)))))
            (SETQ D (NTH 1 |g2544|))
            (SETQ E (NTH 2 |g2544|)))))))
  (list a b c d e))
;=> (1 2 3 4 5)

のように展開されます。

以下、ANSI CLで動くようにしたもの (SBCLのみ対応)

#+sbcl (import 'sb-ext:without-package-locks)

(defun car-safe (form)
  (if (consp form)
      (car form)
      form))

(defun setf-match (pattern object)
  (cond ((eq (car-safe pattern) 'quote)
	 nil)
	(t `(setf ,pattern ,object))))

(without-package-locks
  (define-setf-expander list (&rest elts)
    (let ((storevar (gensym)))
      (values nil nil (list storevar)
              (do ((i 0 (1+ i))
                   (accum)
                   (args elts (cdr args)))
                  ((null args)
                   (cons 'progn (nreverse accum)))
                (push (setf-match (car args) `(nth ,i ,storevar)) accum))
              `(incorrect-structure-setf list . ,elts)))))

#+sbcl
(without-package-locks
  (define-setf-expander sb-impl::backq-list (&rest elts)
    (let ((storevar (gensym)))
      (values nil nil (list storevar)
              (do ((i 0 (1+ i))
                   (accum)
                   (args elts (cdr args)))
                  ((null args)
                   (cons 'progn (nreverse accum)))
                (push (setf-match (car args) `(nth ,i ,storevar)) accum))
              `(incorrect-structure-setf list . ,elts)))))

(without-package-locks
  (define-setf-expander list* (&rest elts)
    (let ((storevar (gensym)))
      (values nil nil (list storevar)
              (do ((i 0 (1+ i))
                   (accum)
                   (args elts (cdr args)))
                  ((null args)
                   (cons 'progn (nreverse accum)))
                (cond ((cdr args)
                       (push (setf-match (car args) `(nth ,i ,storevar)) accum))
                      (t (push (setf-match (car args) `(nthcdr ,i ,storevar)) accum))))
              `(incorrect-structure-setf list* . ,elts)))))

#+sbcl
(without-package-locks
  (define-setf-expander sb-impl::backq-list* (&rest elts)
    (let ((storevar (gensym)))
      (values nil nil (list storevar)
              (do ((i 0 (1+ i))
                   (accum)
                   (args elts (cdr args)))
                  ((null args)
                   (cons 'progn (nreverse accum)))
                (cond ((cdr args)
                       (push (setf-match (car args) `(nth ,i ,storevar)) accum))
                      (t (push (setf-match (car args) `(nthcdr ,i ,storevar)) accum))))
              `(incorrect-structure-setf list* . ,elts)))))

(without-package-locks
  (define-setf-expander cons (car cdr)
    (let ((storevar (gensym)))
      (values nil nil (list storevar)
              `(progn ,(setf-match car `(car ,storevar))
                      ,(setf-match cdr `(cdr ,storevar)))
              `(incorrect-structure-setf cons ,car ,cdr)))))

#+sbcl
(without-package-locks
  (define-setf-expander sb-impl::backq-cons (car cdr)
    (let ((storevar (gensym)))
      (values nil nil (list storevar)
              `(progn ,(setf-match car `(car ,storevar))
                      ,(setf-match cdr `(cdr ,storevar)))
              `(incorrect-structure-setf cons ,car ,cdr)))))

(defmacro incorrect-structure-setf (&rest args)
  (error "You cannot SETF the place ~S~% in a way that refers to its old contents." args))

CADRでは、listや、list*にしかSETFは定義されていませんが、SBCLの場合は、リーダーマクロはBACKQ-LIST等に展開されるので、そちらも対処。

SETFが再帰的に展開されるというのも面白いですが、なによりバッククォート式やリストにSETFを定義するという発想が素晴しいですね。

他には、LETやPROGNなどのSETFも定義されています。 (ちなみに、CLISPでは、IFなどにもSETFが定義されているようです。)

2010-09-11

ZetalispのPKG-BIND

| 23:47 | ZetalispのPKG-BIND - わだばLisperになる を含むブックマーク はてなブックマーク - ZetalispのPKG-BIND - わだばLisperになる

LispマシンのLISPであるZetalisp/Lisp machine lispには、PKG-BINDというのがあって

(PKG-BIND "FOO"
  (DEFUN FOO (N) N))

のように指定した範囲だけパッケージが指定できます。

パッケージの仕組みからして違うのでそもそもCLで再現できるのか分からないのですが、今日Twitterでやりとりをしている中でS式を一旦文字列にしてREAD-FROM-STRINGすれば良いかと思い

(DEFMACRO PKG-BIND (&WHOLE WHOLE PKG &BODY BODY)
  (LET ((PKG-BIND-PKG (PACKAGE-NAME (SYMBOL-PACKAGE (CAR WHOLE)))))
    `(LET ((*PACKAGE* (FIND-PACKAGE ,PKG)))
       (EVAL
        (READ-FROM-STRING
         ,(WRITE-TO-STRING 
           `(PROGN 
              (IMPORT (READ-FROM-STRING
                       ,(FORMAT NIL 
                                "~A::PKG-BIND"
                                PKG-BIND-PKG)))
              ,@BODY)))))))

みたいなものを作成しました。

ZetalispのPKG-BINDが入れ子にできるのかどうか不明なのですが、とりあえず入れ子に対応。

(DEFPACKAGE :FOO (:USE :CL))
(PKG-BIND :FOO
  (DEFUN FOO (N) N)

  (DEFPACKAGE :BAR (:USE :CL))
  (PKG-BIND :BAR
    (DEFUN BAR (N) N)

    (DEFPACKAGE :BAZ (:USE :CL))
    (PKG-BIND :BAZ
      (DEFUN BAZ (CL-USER::N) CL-USER::N))))

(LIST (FOO::FOO 8)
      (BAR::BAR 8)
      (BAZ::BAZ 8))
;⇒ (8 8 8)

EVALを使うので外部のレキシカルな変数は取り込めないのですが、この方法以外でインターンするシンボルを選り分けるのは、なかなか面倒なので、まあ、これで良いかなと妥協。

以前はボディを走査してシンボルのパッケージを書き換えるという方法を試してみていました。

書き方が悪かった所為で上手く行かなかったような気もするので、シンボルを操作する方法でも書いてみたいと思います。

2009-01-07

%fooの由来

| 18:15 | %fooの由来 - わだばLisperになる を含むブックマーク はてなブックマーク - %fooの由来 - わだばLisperになる

またまたLispマシンネタなのですが、%fooの由来がLispマシンなのではないかということでネタにしてみることにしました。

%fooという関数名は、現在の慣習では内部的な関数ということを意味し、利用にも注意が必要ということが多いと思うのですが、Lispマシンでは、%fooはLISPのレベルより下のマイクロコードで組まれた関数を意味していました。

利用上の注意は恐らく同じだと思うのですが、マイクロコードで組まれていなければ、%は付かず、LISPレベルでの下請け的な関数は、foo1、foo2としていることが多いようです。(foo1は、fooのfoo2はfoo1の下請け)

2009-01-05

どう書く〜#` リーダーマクロ〜

| 20:08 | どう書く〜#` リーダーマクロ〜 - わだばLisperになる を含むブックマーク はてなブックマーク - どう書く〜#` リーダーマクロ〜 - わだばLisperになる

またまたLispマシンのマニュアルを眺めていて、変ったリーダーマクロをみつけました。

#'は、MacLISPの時代からfunctionなのですが、Lispマシンには#`の定義があったようです。

その内容なのですが、

#`(send stream ',(:clear-input :clear-output))
;>>>
(progn (send stream :clear-input)
       (send stream :clear-output))

#`(rename-file ,("foo" "bar") ,("ofoo" "obar"))
;>>>
(progn (rename-file "foo" "ofoo")
       (rename-file "bar" "obar"))

というもののようです。さらにネストできて

#`#`(print (* ,(5 7) ,,(11. 13.)))
;>>>
(progn (progn (print (* 5 11.)) (print (* 7 11.)))
       (progn (print (* 5 13.)) (print (* 7 13.))))

になるらしいです。

最初の2つは比較的簡単にできたのですが、最後の例がなんだか良く分かりません。

ということで、興味のある方は再現に挑戦してみては如何でしょうか!

ちなみに来週位に私の解答を発表してみたいと思います。

※最初の例のquoteの解釈ですが、もしかしたら誤植で、

(progn (send stream ':clear-input)
       (send stream ':clear-output))

かもしれません、TI-Explorerのエミュレータではこの様に展開されています。

Lispマシンのクロージャ

| 00:16 | Lispマシンのクロージャ - わだばLisperになる を含むブックマーク はてなブックマーク - Lispマシンのクロージャ - わだばLisperになる

Lispマシンのマニュアルを眺めていてクロージャの説明の項にこんなコードがありました。

(deff print-in-base-16
      (let ((*print-base* 16.))
        (closure '(*print-base*) 'print)))

(print-in-base-16 64)
;>> 40
;=> 64

Common Lispで書くなら、こんな感じです。

(setf (symbol-function 'print-in-base-16)
      (let ((*print-base* 16)) 
        #'print))

おお、なるほど、こんな書き方があったかと思ったのですが、良く考えるとCommon Lispだと、*print-base*はスペシャル変数なので閉じ込められません。

(print-in-base-16 64)
;>> 64
;=> 64

しかし普通に

(defun print-in-base-16 (num)
  (let ((*print-base* 16))
    (print num)))

(print-in-base-16 64)
;>> 40
;=> 64

と書いておけば良く、これならLispマシンでもCommon Lispでも同じ動作で、どちらかというとLispマシンの例がトリッキーな気もします。

しかし、

;; /tmpのファイルをファイル名だけで読める
(defun load-in-tmp (file)
  (let ((*default-pathname-defaults* #P"/tmp/"))
    (load file)))

のように色々工夫できることを教えられた気がするので、とりあえず良かったかなと。

ちなみに、LispマシンのLISPは、Zetalispなのですが、基本的にダイナミックスコープで、クロージャは特殊な構文を使って実現します(上のclosureという構文)。