(defvar *verbose* t) ;;; (defstruct class (name nil) (local-variables nil) (functions (make-hash-table)) (parent nil)) ;;; (defvar *all-classes* nil) ;;; (defparameter object 'object) ;;; (defun initialize-class-system () (if *all-classes* (clrhash *all-classes*) (setf *all-classes* (make-hash-table))) (setf (gethash object *all-classes*) (make-class :name object)) (defmethod object (:local-vars () (mapcar #'local-var (class-local-variables (get-class (send self 'class))))) ) )クラスを定義するdefclassが行なうことは,クラスの構造体データをひとつ作 り,それを大域変数*all-classes*に代入されているハッシュ表にクラス名を キーにして蓄える.
(defmacro defclass (class-name &key ((:super s) object) slots) `(progn (defparameter ,class-name ',class-name) (define-class ',class-name ',s ',slots))) (defun defined-class? (class-name) (gethash class-name *all-classes*)) (defun define-class (class-name parent local-vars) (let* ((locals (get-all-local-vars (if parent parent object) local-vars)) (class (make-class :name class-name :parent (or parent object) :local-variables locals :functions (if (defined-class? class-name) (class-functions (get-class class-name)) (make-hash-table))))) (store-class class-name class))) (defun store-class (class-name class) (if *verbose* (format t "; class ~a defined under ~a.~%" class-name (class-parent class))) (setf (gethash class-name *all-classes*) class)) ;;; (defun local-var (loc-var) (if (atom loc-var) loc-var (car loc-var))) (defun get-all-local-vars (parent loc-vars) (remove-duplicates (append (class-local-variables (get-class parent)) loc-vars) :key #'local-var)) ;;; (defun get-class (class-name) (cond ((gethash class-name *all-classes*)) (t (error "~a is an undefined class" class-name))))