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 |

2010-07-20

KMRCLを眺める(176) FIND-TEST-GENERIC-FUNCTIONS

| 23:44 | KMRCLを眺める(176) FIND-TEST-GENERIC-FUNCTIONS - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める(176) FIND-TEST-GENERIC-FUNCTIONS - わだばLisperになる

KMRCLを眺めるのも久々ですが、今回は、KMRCLのsymbols.lispからFIND-TEST-GENERIC-FUNCTIONSです。

とりあえず、ぱっとみで何をするものなのか良く分からないので、ドキュメントストリングを読んだり、コードを眺めたりですが、動作は、

(DEFCLASS FOO () ())

(DEFMETHOD TEST-FOO ((X FOO)))
(DEFMETHOD TEST-FOO1 ((X FOO)))
(DEFMETHOD TEST-FOO2 ((X FOO)))

(KL::FIND-TEST-GENERIC-FUNCTIONS (MAKE-INSTANCE 'FOO))
;⇒ (TEST-FOO2 TEST-FOO TEST-FOO1)

となるようです。

上では、FOOというクラスを作って、そのFOOに関連する総称関数を作成していて、それらはすべてTEST-という名前で始まっています。

どうも、FIND-TEST-GENERIC-FUNCTIONSは、こういう総称関数を探し出すもののようです。

テストを書くときに使うと便利だったりするんでしょうか…。

定義は、

(defun find-test-generic-functions (instance)
  "Return a list of symbols for generic functions specialized on the
class of an instance and whose name begins with the string 'test-'"
  (let ((res)
        (package (symbol-package (class-name (class-of instance)))))
    (do-symbols (s package)
      (multiple-value-bind (sym status)
          (find-symbol (symbol-name s) package)
        (when (and (or (eq status :external)
                       (eq status :internal))
                   (fboundp sym)
                   (eq (symbol-package sym) package)
                   (> (length (symbol-name sym)) 5)
                   (string-equal "test-" (subseq (symbol-name sym) 0 5))
                   (typep (symbol-function sym) 'generic-function)
                   (plusp
                    (length
                     (compute-applicable-methods
                      (ensure-generic-function sym)
                      (list instance)))))
          (push sym res))))
    (nreverse res)))

となっています。