Posted 2021-08-05 04:37:09 GMT
前回は、クラス定義のdefine-typeとメッセージ送信構文の=>あたりを適当に辻褄を合せて作りましたが、マニュアルを読み進めて、define-methodあたりまでを作成してみます。
CommonObjectsではFlavorsと同じくアクセサを一括で作成する機能があるようです。gettable、settable、initableというのも同じですが、Flavorsではinitableのスペルがinittableだったりinitableだったりします。initableなのは、gettable、settableと文字数を合せたかったからなのでしょうか……。
このオプションの処理をどこに加えようかと考えましたが、とりあえず、define-typeのマクロに押し込めてしまうことにしました。
後々適切なプロトコルを思い付いたらそちらで処理します。
(defmacro define-type (type-name &optional doc-string &body slots &environment environment)
(declare (ignore environment))
(if (typep doc-string 'string)
(setq slots (cdr slots))
(setq slots (cons doc-string slots)
doc-string nil))
(let ((slots (copy-tree (remove-if #'keywordp slots)))
(opts (remove-if (complement #'keywordp) slots)))
(dolist (s slots)
(when (find :all-initable opts)
(push :initable (cddr s)))
(when (find :all-gettable opts)
(push :gettable (cddr s)))
(when (find :all-settable opts)
(push :settable (cddr s))))
`(ensure-common-objects-class ',type-name
:documentation ,doc-string
:direct-slots (list ,@(mapcar #'parse-slot slots)))))define-methodCommonObjectsは総称関数ベースではなくシングルディスパッチのため、前回適当に作成した=>というメッセージ送信の総称関数にどんどんメソッドを足していくことでも何とかなりそうです。
ということでこのように書いてみました。
(defmacro define-method ((type message) (&rest args) &body body)
(let ((slots (mapcar #'slot-definition-name (class-slots (find-class type)))))
`(defmethod => ((obj ,type) (msg (eql ,message)) &rest args)
(let ((self obj))
(declare (ignorable self))
(destructuring-bind (,@args) args
(with-slots ,slots obj
(declare (ignorable ,@slots))
,@body))))))特徴的なのは、define-methodの内部では、インスタンスのスロットが変数のようにみえる点ですが、この辺りもFlavorsというか一般的なオブジェクト指向言語風です。自身を指す変数であるselfも用意されています。
class-slotsとwith-slotsを組合せて使っていますが、原理的にdefine-methodの定義時にクラスのスロットが確定している必要があります。
CommonObjectsはあまり動的ではなさそうにみえるので、多分これで大丈夫でしょう。
ちなみに、全部実行時に持っていくとすると、progv等を使うことになりそうです。
Common Lisp標準では、スロットは未束縛の状態を持ちますが、CommonObjectsでは未定義値が入るようです。
実装としては、slot-unboundメソッドを定義したり、initialize-instanceで未定義値で初期化したりと色々な方策が考えられますが、今回は、allocate-instanceでCommonObjects用の未定義値を入れてみることにします。
(defstruct undefined-slot-value)(defvar *undefined-slot-value* (make-undefined-slot-value))
(defmethod allocate-instance ((class common-objects-class) &rest initargs)
(let ((instance (call-next-method)))
(dolist (s (class-slots class))
(setf (slot-value-using-class class instance (slot-definition-name s))
*undefined-slot-value*))
instance))
マニュアルにある例を動かして確認してみます
(define-type vector-instance
(:var theta (:type float) (:init 0))
(:var magnitude (:type float))
:all-settable)
(define-method (vector-instance :scale) (x)
(setq magnitude (* x magnitude)))
(=> (make-instance 'vector-instance) :scale 3)
!!! In * of (3 #S(undefined-slot-value)) arguments should be of type number.
(define-type bank-account
(:var holder (:type simple-string))
(:var acct-num)
(:var balance (:type number))
:all-initable
:all-gettable)
(defun open-account (name number initial-balance)
(if (and (simple-string-p name)
(numberp initial-balance)
(> initial-balance 0))
(make-instance 'bank-account
:holder name
:acct-num number
:balance initial-balance)
(error "Bad name: ~A or Balance: ~A " name initial-balance)))
(setq acct1 (open-account "Bobby Brown" '555-55-5555 100.00))
→ #<bank-account 40100FA453>
(=> acct1 :balance )
→ 100.0
(define-method (bank-account :deposit) (amount)
(if (and (numberp amount) (> amount 0))
(setf balance (+ balance amount))
(error "Bad deposit amount ~A" Amount)))
(=> acct1 :deposit 50)
→ 150.0
(=> acct1 :balance)
→ 150.0
(define-method (bank-account :withdraw) (amount)
(cond ((or (not (numberp amount)) (< amount 0))
(error "Improper Withdrawal Amount ~A" amount))
((< balance amount)
(error "Insufficient Funds -- Transaction denied"))
(T (setf balance (- balance amount)))))
(=> acct1 :withdraw 25)
→ 125.0
(=> acct1 :balance)
→ 125.0
MOPがサポートされていると標準以外のオブジェクト指向システムを構築していくのも比較的簡単な気がしてきました。
今後のドメイン特化オブジェクト指向システム時代の到来を期待したい……。
次回は、継承まわりを実装してみます。
■
HTML generated by 3bmd in LispWorks 7.0.0