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 |

2009-12-03

KMRCLを眺める (29) with-ignore-errors

| 22:30 | KMRCLを眺める (29) with-ignore-errors - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (29) with-ignore-errors - わだばLisperになる

今回は、KMRCLのmacros.lispの中からWITH-IGNORE-ERRORSです。

その名前から想像できるように、ボディ部をIGNORE-ERRORSで包むというもので定義はこんな感じです。

(defmacro with-ignore-errors (&rest forms)
  `(progn
     ,@(mapcar
        (lambda (x) (list 'ignore-errors x))
        forms)))
(WITH-IGNORE-ERRORS 
  (ERROR "foo")
  (ERROR "bar")
  (ERROR "baz"))

(PROGN
  (IGNORE-ERRORS (ERROR "foo"))
  (IGNORE-ERRORS (ERROR "bar"))
  (IGNORE-ERRORS (ERROR "baz")))

のように展開されます。式が一つずつIGNORE-ERRORSで包まれています。

(WITH-IGNORE-ERRORS 
  (ERROR "foo")
  (ERROR "bar")
  (ERROR "baz"))
;=> NIL
;   #<SIMPLE-ERROR {100BD5FFE1}>

とにかく手短にエラーを無視したいときには便利なのではないでしょうか。

KMRCLを眺める (28) def-cached-instance

| 00:40 | KMRCLを眺める (28) def-cached-instance - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (28) def-cached-instance - わだばLisperになる

今回は、KMRCLのmacros.lispの中からDEF-CACHED-INSTANCEです。

前回のDEF-CACHED-VECTORに引き続き、今度はインスタンスをキャッシュして使い回すんだろうと思います。

定義は、

(defmacro def-cached-instance (name)
  (let* ((new-name (concat-symbol "new-" name "-instance"))
         (release-name (concat-symbol "release-" name "-instance"))
         (cache-name (concat-symbol "*cached-" name "-instance-table*"))
         (lock-name (concat-symbol "*cached-" name "-instance-lock*")))
    `(eval-when (:compile-toplevel :load-toplevel :execute)
       (defvar ,cache-name nil)
       (defvar ,lock-name (make-lock ',name))

         (defun ,new-name ()
           (with-lock-held (,lock-name)
             (if ,cache-name
                 (pop ,cache-name)
                 (make-instance ',name))))

         (defun ,release-name (instance)
           (with-lock-held (,lock-name)
             (push instance ,cache-name))))))

で、

マクロ展開は、

(DEF-CACHED-INSTANCE FOO)

;==>

(EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
  (DEFVAR *CACHED-FOO-INSTANCE-TABLE* NIL)
  (DEFVAR *CACHED-FOO-INSTANCE-LOCK* (MAKE-LOCK 'FOO))
  (DEFUN NEW-FOO-INSTANCE ()
    (WITH-LOCK-HELD (*CACHED-FOO-INSTANCE-LOCK*)
      (IF *CACHED-FOO-INSTANCE-TABLE*
          (POP *CACHED-FOO-INSTANCE-TABLE*)
          (MAKE-INSTANCE 'FOO))))
  (DEFUN RELEASE-FOO-INSTANCE (INSTANCE)
    (WITH-LOCK-HELD (*CACHED-FOO-INSTANCE-LOCK*)
      (PUSH INSTANCE *CACHED-FOO-INSTANCE-TABLE*))))

という感じです、前回のDEF-CACHED-VECTORに比べてわかりやすいです。

動作としては、

;; FOOクラス作成
(DEFCLASS FOO () ())

;; 10個貯める
(DOTIMES (I 10 *CACHED-FOO-INSTANCE-TABLE*)
  (RELEASE-FOO-INSTANCE (MAKE-INSTANCE 'FOO)))
;⇒ (#<FOO {***100BC2C051****}> #<FOO {100BC2C011}> #<FOO {100BC2BFD1}>
;    #<FOO {100BC2BF91}> #<FOO {100BC2BF51}> #<FOO {100BC2BF11}>
;    #<FOO {100BC2BED1}> #<FOO {100BC2BE91}> #<FOO {100BC2BE51}>
;    #<FOO {%%%100BC2BE11%%%}>)

;; 15個取り出す
(LET (ANS)
  (DOTIMES (I 15)
    (PUSH (NEW-FOO-INSTANCE) ANS))
  (LIST ANS '<= *CACHED-FOO-INSTANCE-TABLE*))
;⇒ ((#<FOO {100C3587D1}> #<FOO {100C358791}> #<FOO {100C358751}>
;     #<FOO {100C358711}> #<FOO {100C3586D1}> #<FOO {%%%100BC2BE11%%%}>
;     #<FOO {100BC2BE51}> #<FOO {100BC2BE91}> #<FOO {100BC2BED1}>
;     #<FOO {100BC2BF11}> #<FOO {100BC2BF51}> #<FOO {100BC2BF91}>
;     #<FOO {100BC2BFD1}> #<FOO {100BC2C011}> #<FOO {***100BC2C051***}>)
;     <= NIL)

キャッシュしたインスタンスを全部取り出した後は、新規作成して返すという動きがなんとなく分かるかと思います。

前回のDEF-CACHED-VECTORの時から名前に通常のシンボルが使えないというのは、なにか変だと思っていたのですが、KMRCLのMAKE-LOCKがSBCLの場合に上手く機能していなかったようです。

具体的には、SB-THREAD:MAKE-MUTEXの:name引数にはNILか文字列なのですが、ここにシンボルが渡ってきてしまっていたのが問題でした。

(defun make-lock (name)
  #+allegro (mp:make-process-lock :name name)
  #+cmu (mp:make-lock name)
  #+lispworks (mp:make-lock :name name)
  #+sb-thread (sb-thread:make-mutex :name (STRING name)) ;(STRING)を噛ませることで修正
  #+openmcl (ccl:make-lock name)
  )