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