named-instance-class

named-instance-class.lisp

;;; -*- mode: Lisp; coding: utf-8  -*-

(ql:quickload 'closer-mop)


(defpackage named-instance-class 
  (:use c2cl))


(in-package named-instance-class)


(defclass named-instance-class (standard-class) ())


;; check-super-metaclass-compatibility
;;  はvalidate-superclassの古い名称
(defmethod validate-superclass ((subclass named-instance-class) (superclass standard-class))
  T)


(defclass named-object (standard-object)
  ((name :initform nil :initarg :name :reader object-name)))


;; インスタンスのクラスを自動で挿入するという常套句らしい
;;  他にも色々な書き方があるらしい。参照: https://www.cliki.net/MOP%20design%20patterns

(defun insert-base-class (base-name cpl)
  (let ((base-class (find-class base-name)))
    (if (member base-class cpl) 
        cpl
        (let ((tail (member (find-class 'standard-object) cpl)))
          (append (ldiff cpl tail) (cons base-class tail))))))


(defmethod compute-class-precedence-list ((class named-instance-class))
  (insert-base-class 'named-object (call-next-method)))


;;;


(defvar *named-instances* (make-hash-table))


(defun find-named-instance (name &optional (errorp t))
  (or (gethash name *named-instances*)
      (when errorp (error "No instance named ~S." name))))


(defmethod make-instance :around ((class named-instance-class)
                                  &rest initargs
                                  &key (name nil namep)) 
  ;; :name の処理を変更
  ;; 1) getfで:nameを探すというのは最近はあまりやらないのでは?
  ;; 2) nil という名前が有効でない
  (if (null namep)
      (call-next-method)
      (let ((old (find-named-instance name nil)))
        (if old
            (cond ((eq class (class-of old))
                   ;; :allow-other-keys T で:name 引数を許可する
                   ;;  remf で :nameを消すという方法もあり
                   (apply #'reinitialize-instance old :allow-other-keys T initargs)
                   old)
                  (t (error "~S already names an instance. but its class isn't ~S." name class)))
            (setf (gethash name *named-instances*)
                  (call-next-method))))))


;; 試してみる
#||

(defclass foo ()
  ()
  (:metaclass named-instance-class))

(finalize-inheritance (find-class 'foo))

(defclass bar (foo)
  ()
  (:metaclass named-instance-class))

(finalize-inheritance (find-class 'bar))

(class-precedence-list (find-class 'foo))
→ (#<named-instance-class foo 40F0448D0B>
   #<lisp:standard-class named-object 41300C46AB> ;; defclassで明示せずとも自動でstandard-objectの直下に挿入されている
   #<lisp:standard-class standard-object 41B06643E3> 
   #<built-in-class t 41B0039F0B>)


(eq (make-instance 'foo :name 'george)
    (make-instance 'foo :name 'george))

(class-precedence-list (find-class 'bar))
→ (#<named-instance-class bar 40101ED6FB>
   #<named-instance-class foo 4010049F33>
   #<lisp:standard-class named-object 40E02A2013>
   #<lisp:standard-class standard-object 41B06643E3>
   #<built-in-class t 41B0039F0B>)


(make-instance 'bar :name 'george)
Error: george already names an instance. but its class isn't #<named-instance-class bar 40E02E7E3B>.

||#

()


;;; *EOF*