15.2 クラス定義の実現

Next: 15.3 メソッドの実現 Up: 15 CLOSのクラスシステムの実現 Previous: 15.1 クラスの実現

15.2 クラス定義の実現

クラス定義は，defclassですが，システムのdefclassを書き換えるのはよくないので，defclass*という名前でクラス定義用マクロを定義することにします．


(defmacro defclass* (cls-name parents local-vars)
  (let
      ((slot-vars (parse-slot-vars local-vars))
       (accessors (parse-accessors local-vars)))
    `(define-class ',cls-name
         ',parents ',slot-vars ',accessors)))
;;;
(defun parse-slot-vars (local-vars)
  (mapcar
   #'(lambda (x)
       (cond
        ((atom x) x)
        (t (list
            (car x)
            (cadr (member :initform (cdr x)))))))
   local-vars))

(defun parse-accessors (local-vars)
  (mapcar
   #'(lambda (x)
       (cond
        ((atom x)
         (list x x (intern (format nil "SET-~a" x))))
        (t (list
            (car x)
            (or (cadr (member :accessor (cdr x))) (car x))
            (intern (format nil "SET-~a" (car x)))))))
   local-vars))
;;;
(defun define-class
  (cls-name parents local-vars local-accessors)
  (let*
      ((locals (get-all-local-vars
                (if parents parents '(t)) local-vars))
       (accessors
        (get-all-accessors
            (if parents parents '(t))
            local-accessors))
       (class (make-cls
               :name cls-name
               :parents (if parents parents '(t))
               :local-variables locals
               :accessors accessors
               :functions
               (if (defined-class? cls-name)
                   (cls-functions (get-class cls-name))
                 (make-hash-table)))))
    (mapc #'create-local-var-generic-function accessors)
    (store-class cls-name class)))


(defun create-local-var-generic-function (var&accessor)
  (let* ((local-var (car var&accessor))
         (accessor (cadr var&accessor))
         (set-accessor (caddr var&accessor)))
    (setf (symbol-function accessor)
          (eval `(function (lambda (self)
                             (send self ',accessor)))))
    (eval
     `(defsetf ,accessor
        (self) (value)
        (list 'send self '',set-accessor value)))
    ))

(defun local-var (loc-var)
  (if (atom loc-var) loc-var (car loc-var)))

(defun get-all-local-vars (parents loc-vars)
  (dolist
      (parent parents
        (remove-duplicates
         loc-vars :key #'local-var))
    (setf loc-vars
      (append
       (cls-local-variables (get-class parent))
       loc-vars))))

(defun get-all-accessors (parents loc-accs)
  (dolist (parent parents loc-accs)
    (setf loc-accs
      (append (cls-accessors (get-class parent))
              loc-accs))))

ここでは，setfで代入が可能となるための手続きを定義するためのdefsetfを用いています．

generated through LaTeX2HTML. M.Inaba 平成18年5月6日