Archive for 2010年7月25日|Daily archive page

newLISP で On Lisp する...第12章(その2の続き)

(この blog は、“short short story または 晴耕雨読な日々”からの引越してきたもの。スクリプトは、newLISP V10.2.1 以降で動作するように書き直しています。
defun 等の newLISP組込関数に無い関数は、特に断らない限り、newlisp-utility.lsponnewlisp.lsp に定義してあります。)

 第12章 汎変数 の最後、インバージョンを定義する です。
 ここに出てくる defsetf も newLISP には、ありません。もちろん、setf の機能が変わることもありません。これで終わりにしても良かったのですが、その2 で示したようにマクロ sortf もできることがわかったし、やるだけやってみようということで、お付き合い下さい。
 先ずは、defsef 改め、マクロdefsetf-i から、

(define *inversion-flag* nil) 
(define-macro (defsetf-i fname vars)
  (letex (_fname fname
          _vars (append vars (args 0))
          _addf (list 'if '*inversion-flag* (args 1) (nth 1 (eval fname))))
    (setf (nth 0 _fname) '_vars)
    (setf (nth 1 _fname) '_addf)))

 追加のマクロを関数に直接埋め込みます。それを取り出すためのフラグも用意します。 gensym の生成は入れていません。
 そして、defsetf-i で定義した部分を呼び出す setf 改め、マクロ setf-i です。

(define-macro (setf-i)
  (setq *inversion-flag* true)
  (letex (_body (eval (append (args 0) (mklist (args 1)))))
    (begin
      (setq *inversion-flag* nil)
      '_body)))

 フラグ *inversion-flag* を true に切り替えて、defsetf-iで定義したマクロを取り出します。もちろん、フラグ *inversion-flag* は nil に戻しておきます。
 さて動作です。関数retrieve を用意します(defun は newlisp-utility.lsp に、values は onnewlisp.lsp に定義してあります)。

(defun retrieve (key)
  (let (x (*cache* (string key)))
    (if x (values x true)
        (lookup key *world*))))   ; or (rest (assoc key *world*)))))

 毎度おなじみ、hash の代わりに context を使っています。newLISP組込lookup は、assoc がリストを返すのに対し、そのリストの cdr部(newLISP では、rest)を返します。多値にも対応しておきます。

> (new Tree '*cache*)
*cache*
> (setq *world* '((a  2) (b  16) (c  50) (d  20) (f  12)))
((a 2) (b 16) (c 50) (d 20) (f 12))
> (retrieve 'c)
50
> (retrieve 'n)
nil
> (setf (retrieve 'n) 77)
77
> (retrieve 'n)
nil
> 

 ここで、マクロdefsetf-i の出番です。

(defsetf-i retrieve (key) (val) 
  (letex (_x (string key) _y val)
     (unless (*cache* _x) (*cache* _x 0)) (setf (*cache* _x) _y)))

 本体の記述は、マクロのそれです。
 そして、マクロsetf-i の動作です(multiple-value-list と multiple-value-bind は onnewlisp.lsp に定義してあります)。

> (retrieve 'n)
nil
> (setf (retrieve 'n) 77)
77
> (retrieve 'n)
nil
> (setf-i (retrieve 'n) 77)
77
> (retrieve 'n)
77
> (multiple-value-list (retrieve 'n))
(77 true)
> (multiple-value-list (retrieve 'c))
(50)
> (*cache*)
(("n" 77))
> *world*
((a 2) (b 16) (c 50) (d 20) (f 12))
> (multiple-value-bind (v b) (retrieve 'n) (list v b))
(77 true)
> (multiple-value-bind (v b) (retrieve 'c) (list v b))
(50 nil)
> (*cache*)
(("n" 78))
> 

 といった具合です。

 ようやく、第12章 汎変数 のまとめです。

 以上、如何でしょうか?

広告