(defmacro define-class (class inst-vars class-vars &body methods) `(let ,class-vars (mapcar #'ensure-generic-fn ',(mapcar #'first methods)) (defun ,class ,inst-vars #'(lambda (message) (case message ,@(mapcar #'make-clause methods)))))) (defun make-clause (clause) `(,(first clause) #'(lambda ,(second clause) .,(cddr clause)))) (defun ensure-generic-fn (message) (unless (generic-fn-p message) (let ((fn #'(lambda (object &rest args) (apply (get-method object message) args)))) (setf (symbol-function message) fn) (setf (get message 'generic-fn) fn)))) (defun generic-fn-p (fn-name) (and (fboundp fn-name) (eq (get fn-name 'generic-fn) (symbol-function fn-name))))というような,define-classというマクロを定義すれば, new-accountの中で行っているように,メッセージごとに case文を作り,そのメッセージごとにGeneric Function を作ります.たとえば,
(define-class account (name &optional (balance 0.00)) ((interest-rate .06)) (withdraw (amt) (if (<= amt balance) (decf balance amt) 'insufficient-funds)) (deposit (amt) (incf balance amt)) (balance () balance) (name () name) (interest () (incf balance (* interest-rate balance))))という具合に口座を定義すれば,
> (setf acct2 (account "inaba" 200)) #<Interpreted Closure ...> > (deposit acct2 30) 230 > (interest acct2) 243.8 > (balance acct2) 243.8という具合に使うことができる. べつのクラスとして,パスワードが必要な口座クラス (password-account)を作るときには, すでにaccountクラスでGeneric Function が作られているので,そのaccountクラスに定義されている メッセージ用の定義は必要なくなる.
(define-class password-account (password acct) () (change-password (pass new-pass) (if (equal pass password) (setf password new-pass) 'wrong-password)) (otherwise (pass &rest args) (if (equal pass password) (apply message acct args) 'wrong-password)))というように定義すると,
> (setf acct3 (password-account "secret" acct2)) #<Interpreted Closure ...> > (balance acct3 "secret") 243.8 > (deposit acct3 "secret" 10) 253.8 > (balance acct3 "secret") 253.8 > (balance acct3 "inaba") WRONG-PASSWORD > (withdraw acct3 "secret" 30) 223.8 > (balance acct3 "secret") 223.8というようにパスワードを必要とする口座acct3に対しても, balance,depositなどの処理が可能となっている. さらに,引き出し額に制限がある口座limited-accountの クラスを以下のように定義すると,
(define-class limited-account (limit acct) () (withdraw (amt) (if (> amt limit) 'over-limit (withdraw acct amt))) (otherwise (&rest args) (apply message acct args)))という具合に,withdrawの定義が異なる定義がなされる. これを実行すると,
> (setf acct4 (password-account "pass" (limited-account 100.00 (account "tanaka" 500.00)))) #<Interpreted Closure ...> > (withdraw acct4 "pass" 200) OVER-LIMIT > (withdraw acct4 "pass" 50) 450.0 > (withdraw acct4 "guess" 20) WRONG-PASSWORDという具合に,password-accountの機能,accountの機能も 利用できるようになる.