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-method
CommonObjectsは総称関数ベースではなくシングルディスパッチのため、前回適当に作成した=>
というメッセージ送信の総称関数にどんどんメソッドを足していくことでも何とかなりそうです。
ということでこのように書いてみました。
(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