change-class

MOP ACに参加してしまったのでMOPサポートを手厚くしたいなぁという欲求が勝手に高まってきている。サポートしていない機能のもっとも大きなものとしてchange-classとクラスの再定義がある。個人的にどちらもあまり(サポートしてないのだから当然だが)使わない機能で今一どういうものかよく分かっていない。とりあえず、オリジナルのAMOPを当たってみることにした。

AMOPで使われているソースはclossette.lispと呼ばれるものらしく、ググって見るとまぁ簡単に見つかった。これとか。

っで、とりあえず、change-classの骸骨だけ作ってみたのが以下。

(import (rnrs) (clos user) (clos core)
        (sagittarius)
        (sagittarius control))

(define (slot-exists? obj slot)
  (slot-exists-using-class? (class-of obj) obj slot))

(define-method slot-exists-using-class? (class obj slot)
  (not (not (assq slot (class-slots class)))))

(define-method change-class ((old <object>) (new-class <class>) :rest initargs)
  (let ((new (allocate-instance new-class initargs)))
    (dolist (slot-name (map slot-definition-name (class-slots new-class)))
      (when (and (slot-exists? old slot-name)
                 (slot-bound? old slot-name))
        (slot-set! new slot-name (slot-ref old slot-name))))
    ;; TODO
    ;;(%swap-slots new old)
    ;;(%swap-class new old)
    (apply update-instance-for-different-class new old initargs)
    old))

(define-method update-instance-for-different-class
  ((old <object>) (new <object>) :rest initargs)
  (let ((added-slots (remove (lambda (slot-name)
                               (slot-exists? old slot-name))
                             (map slot-definition-name 
                                  (class-slots (class-of new))))))
    (apply shared-initialize new added-slots initargs)))

(define-method shared-initialize ((instance <object>) slot-names :rest all-keys)
  (dolist (slot (class-slots (class-of instance)))
    (let ((slot-name (slot-definition-name slot))
          (init-key   (slot-definition-option slot :init-keyword #f))
          (init-value (slot-definition-option slot :init-value #f))
          (init-thunk (slot-definition-option slot :init-thunk #f)))
      ;; init-keyword is the strongest
      (cond ((and init-key (get-keyword init-key all-keys #f))
             => (lambda (v) (slot-set! instance slot-name v)))
            ((and init-value (get-keyword init-value all-keys #f))
             => (lambda (v) (slot-set! instance slot-name v)))
            ((and init-thunk (get-keyword init-thunk all-keys #f))
             => (lambda (v) (slot-set! instance slot-name (v)))))))
  instance)

ほぼオリジナルのコピー。違いはオリジナルはrotatefでスロットとクラスも変更できるがSagittariusではそんなことできないので本体に何かしら手を入れる必要があるといった点と、shared-initializeが美しくない点か。(普通にinitialize呼び出せばいいじゃん、と思ったのだが、そうすると引数チェックとかがユーザーによって定義されていると嬉しくないのだろう。実際多分嬉しくない)

っで多分以下のように使える(予定)。

(define-class <member> ()
  ((name       :init-keyword :name)
   (occupation :init-keyword :occupation)))

(define-class <member2> ()
  ((first-name :init-keyword :first-name)
   (last-name  :init-keyword :last-name)
   (occupation :init-keyword :occupation)
   ))

(define m (make <member> :name "Takashi" :occupation "Programmer"))

(change-class m <member2> :last-name "Kato" :first-name "Takashi")

CLHSのchange-classにある例では明示的に呼んでいるのでこうあるべきなのだろう。

closseteではクラスの再定義は禁止してるみたいなんだけど、CL、Gaucheともに同名のクラスが既にあった場合クラスの再定義プロセスが走るみたいだが、これどうしたものかな。