KMRCLを眺める(235) mop.lisp — #:g1

Posted 2011-11-07 18:49:00 GMT

しばらくブログを書いてないと書くこともまた無くなってしまうのですが、そういう時はライブラリを眺めてたことを思いだしたので、久し振りにKMRCLを眺めてみます。 (前回: KMRCLを眺める(234) repl.lisp) 今回はKMRCLのmop.lispまるごとです。 この mop.lisp は、

;;; This file imports MOP symbols into KMR-MOP packages and then
;;; re-exports them to hide differences in MOP implementations.

とのことなので処理系間のmopの互換性の向上のためのポータビリティレイヤーというところです。最近では、Closer to MOPというプロジェクトがメジャーになりつつあります。 とりあえず、上から順に眺めて行くと、 まず、*features*にkmrcl::処理系-mopという識別シンボルを入れていて、このパッケージの処理に使うようです。
(in-package #:cl-user)

;;;--------------------------------------------------- #+sbcl (eval-when (:compile-toplevel :load-toplevel :execute) (if (find-package 'sb-mop) (pushnew 'kmrcl::sbcl-mop cl:*features*) (pushnew 'kmrcl::sbcl-pcl cl:*features*)))

#+cmu (eval-when (:compile-toplevel :load-toplevel :execute) (if (eq (symbol-package 'pcl:find-class) (find-package 'common-lisp)) (pushnew 'kmrcl::cmucl-mop cl:*features*) (pushnew 'kmrcl::cmucl-pcl cl:*features*)))

;;;----------------------------------- (defpackage #:kmr-mop (:use #:cl #:kmrcl #+kmrcl::sbcl-mop #:sb-mop #+kmrcl::cmucl-mop #:mop #+allegro #:mop #+lispworks #:clos #+clisp #:clos #+scl #:clos #+ccl #:openmcl-mop ) )

#+lispworks (defun intern-eql-specializer (slot) `(eql ,slot))

intern-eql-specializer というのはAMOPで定義されている関数ですが、LispWorksにはないようで、定義があります。 ちなみに、intern-eql-specializer は、EQL-SPECIALIZERメタオブジェクトを返す関数です。
(in-package #:kmr-mop)
(eql (INTERN-EQL-SPECIALIZER 8)
     (INTERN-EQL-SPECIALIZER 8))
;=>  T

(INTERN-EQL-SPECIALIZER 8)
;=>  #<EQL-SPECIALIZER {100C1C2373}>

次の process-class-option、 process-slot-option もLispWorksでなにかするもののようですが、他の処理系ではスルー

(defmacro process-class-option (metaclass slot-name &optional required)
  #+lispworks
  `(defmethod clos:process-a-class-option ((class ,metaclass)
                                           (name (eql ,slot-name))
                                           value)
    (when (and ,required (null value))
      (error "metaclass ~A class slot ~A must have a value" (quote ,metaclass) name))
    (list name `',value))
  #-lispworks
  (declare (ignore metaclass slot-name required))
  )

;;; 同上 (defmacro process-slot-option (metaclass slot-name) #+lispworks `(defmethod clos:process-a-slot-option ((class ,metaclass) (option (eql ,slot-name)) value already-processed-options slot) (list* option `',value already-processed-options)) #-lispworks (declare (ignore metaclass slot-name)) )

ここで、処理系のmop系のパッケージから色々インポート
(eval-when (:compile-toplevel :load-toplevel :execute)
  (shadowing-import
   .......
   ))
そしてエクスポート
(eval-when (:compile-toplevel :load-toplevel :execute)
  (export '(class-of class-name class-slots find-class
            standard-class
            slot-definition-name finalize-inheritance
            standard-direct-slot-definition
            standard-effective-slot-definition validate-superclass
            compute-effective-slot-definition-initargs
            direct-slot-definition-class effective-slot-definition-class
            compute-effective-slot-definition
            slot-value-using-class
            class-prototype generic-function-method-class intern-eql-specializer
            make-method-lambda generic-function-lambda-list
            compute-slots
            class-direct-slots
            ;; KMR-MOP encapsulating macros
            process-slot-option
            process-class-option))
仕事が終ったので、*features*から、先述のシンボルを削除
  #+sbcl
  (if (find-package 'sb-mop)
      (setq cl:*features* (delete 'kmrcl::sbcl-mop cl:*features*))
      (setq cl:*features* (delete 'kmrcl::sbcl-pcl cl:*features*)))

#+cmu (if (find-package 'mop) (setq cl:*features* (delete 'kmrcl::cmucl-mop cl:*features*)) (setq cl:*features* (delete 'kmrcl::cmucl-pcl cl:*features*)))

compute-effective-slot-definition、direct-slot-definition-classの引数が3より少なければ、short-arg-cesd、short-arg-dsdcを*features*に登録するようですが、他のソースでも使っていないようで何に使うのかは不明。
  (when (< (length (generic-function-lambda-list
                     (ensure-generic-function
                      'compute-effective-slot-definition)))
            3)
    (pushnew 'short-arg-cesd cl:*features*))

(when (< (length (generic-function-lambda-list (ensure-generic-function 'direct-slot-definition-class))) 3) (pushnew 'short-arg-dsdc cl:*features*))

) ;; eval-when

以上で、定義は終了。 Closer to MOPと、KMR-MOPの差を調べてみましたが、
(import 'com.informatimago.common-lisp.package:PACKAGE-EXPORTS)
;=>  T

(set-difference  (package-exports :kmr-mop)
                 (package-exports :c2mop)
                 :test #'string=)
;=>  (CLASS-OF COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS CLASS-NAME
;              PROCESS-SLOT-OPTION PROCESS-CLASS-OPTION FIND-CLASS)

となりました。 CLASS-OF、CLASS-NAME、 FIND-CLASS はCLの標準、PROCESS-SLOT-OPTION、PROCESS-CLASS-OPTIONは、KMR-MOPで定義したもの、残る、COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS は、処理系によっては持っているもののようで、スロット定義のINITARGが取得できるようです
(defclass zot ()
  (a b c) )
(finalize-inheritance (find-class 'zot))

(let ((c (find-class 'zot))) (mapcar (lambda (s) (COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS c (list s))) (class-slots c))) ;=> ((:NAME A :INITFORM NIL :INITFUNCTION NIL :INITARGS NIL :ALLOCATION :INSTANCE ; :ALLOCATION-CLASS #<STANDARD-CLASS ZOT> :TYPE T :CLASS #<STANDARD-CLASS ZOT> ; :DOCUMENTATION NIL) ; (:NAME B :INITFORM NIL :INITFUNCTION NIL :INITARGS NIL :ALLOCATION :INSTANCE ; :ALLOCATION-CLASS #<STANDARD-CLASS ZOT> :TYPE T :CLASS #<STANDARD-CLASS ZOT> ; :DOCUMENTATION NIL) ; (:NAME C :INITFORM NIL :INITFUNCTION NIL :INITARGS NIL :ALLOCATION :INSTANCE ; :ALLOCATION-CLASS #<STANDARD-CLASS ZOT> :TYPE T :CLASS #<STANDARD-CLASS ZOT> ; :DOCUMENTATION NIL))

という感じで、久々にKMRCLをつらつら眺めてみましたが、Closer to MOPの方が規模が大きいので、現状では、Closer to MOPを使って互換性を担保するのが吉なのかなというところです。 ■

comments powered by Disqus