etolisp 進捗 (28) 〜 Object Systemの実装 (2):defclass
今日は defclass の実装。継承もスタティックメンバもサポートできた。この辺,赤い本は少ししか言及がないので,理解が正しいかどうか不安だ。取りあえず本に載っているコードは全て動くようになった。Precedence も,図を書いて説明すると複雑そうだが,実装の観点からすれば単なる深さ優先探索なので,実にシンプルなものだった。ただ終わった後で,アクセサに型チェックの仕組みがないことに気付いた。なので,
(defclass box () (width height)) (defclass rect () (width height)) (setf b (make-instance 'box)) (setf (rect-width b) 10) ;; box のインスタンスに rect のアクセサでアクセス
こういうコードがまかり通ってしまう。わはは。いい感じ。
追記:上記のヘンタイ動作は修正済み。今はこんなかんじ。
etolisp> (defclass box () (width height)) => t etolisp> (defclass rect () (width height)) => t etolisp> (setf b (make-instance 'box)) => #<Etolisp-Object (box) 0x1b330f0> etolisp> (setf (rect-width b) 10) ERRR: width is not an available slot name for the object. ERRR: slot-accessor failed. RUNTIME ERROR: setf failed. 1 error(s)
Common-Lisp の本を読んで言語のようなものを実装しているけど,Common-Lisp を作っていると主張するのは止めることにしよう…。もともと,仕様書の余りの大きさに頭痛がして,見てないし。
当初,実装方針に多少のブレはあったものの,そろそろ落ち着いてきた。今は自家製のC++のフレームワークがLisp(※俺Lisp)の世界を忠実に再現しつつあって,新しい機能が迷い無く追加できている。次は defmethod かな。
今日の成果:
(defclass sculpture () (height width depth)) (defclass statue (sculpture) (subject)) (defclass metalwork () (metal-type)) (defclass casting (metalwork) ()) (defclass cast-statue (statue casting) ()) (setf s (make-instance 'cast-statue)) : (setf (metalwork-metal-type s) 'titan) (metalwork-metal-type s) ; => titan :
スタティックメンバも動く
(defclass pokemon () ((class-id :initform 1 :allocation :class))) (setf c1 (make-pokemon)) (setf c2 (make-pokemon)) (pokemon-class-id c1) ; => 1 (pokemon-class-id c2) ; => 1 (setf (pokemon-class-id c1) 10) (pokemon-class-id c1) ; => 10 (pokemon-class-id c2) ; => 10 (setf (pokemon-class-id c2) 20) (pokemon-class-id c1) ; => 20 (pokemon-class-id c2) ; => 20
課題:こういう時の正しい動作は何なんだろう
(defclass left () (member)) (defclass right () (member)) (defclass middle (left right) ()) (setf m (make-instance 'middle)) (setf (slot-value m 'member) 10) (left-member m) ; => 10 (right-member m) ; => nil? 10?
そもそも,SBCLのインタラクティブシェルだとアクセサが定義されないし。どうなんだ。俺Lispは 10, nil を支持(後で対応)。
追記:俺Lisp案を採用。左優先で多重継承できてる。
(defclass left () (member)) (defclass right () (member)) (defclass pokemon (left right) ()) (setf p (make-instance 'pokemon)) (setf (slot-value p 'member) 10) (slot-value p 'member) ;; => 10 (left-member p) ;; => 10 (right-member p) ;; => nil (setf (right-member p) 20) (left-member p) ;; => 10 (setf (left-member p) 30) (slot-value p 'member) ;; => 30