File: cx-singleton-class.lisp

package info (click to toggle)
cl-contextl 0.40-2
  • links: PTS
  • area: main
  • in suites: lenny
  • size: 248 kB
  • ctags: 298
  • sloc: lisp: 2,271; makefile: 29
file content (90 lines) | stat: -rw-r--r-- 3,627 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
(in-package :contextl)

(defclass singleton-class (standard-class)
  ())

(defmethod validate-superclass
           ((class singleton-class)
            (superclass standard-class))
  t)

(defmethod make-instance ((class singleton-class) &rest initargs)
  (declare (ignore initargs))
  (error "The singleton class ~S cannot be instantiated." class))

(defvar *reinitialize-singleton-class* nil)

(defmethod reinitialize-instance :around
  ((class singleton-class) &key)
  (let ((*reinitialize-singleton-class* t))
    (call-next-method)))

(defclass singleton-direct-slot-definition (standard-direct-slot-definition)
  ((reinitializep :initarg :reinitialize :initform nil :accessor slot-definition-reinitializep)))

(defmethod direct-slot-definition-class ((class singleton-class) &key &allow-other-keys)
  (find-class 'singleton-direct-slot-definition))

(defmethod initialize-instance :around
  ((slotd singleton-direct-slot-definition)
   &rest initargs &key name (allocation :class) reinitialize)
  (declare (dynamic-extent initargs)
           #+(or cmu (and mcl (not openmcl)))
           (ignore reinitialize))
  (restart-case
      (unless (eq allocation :class)
        (error "The allocation of the singleton class slot ~S must be :CLASS, but is defined as ~S."
               name allocation))
    (continue ()
      :report (lambda (stream) (format stream "Use allocation ~S anyway." allocation)))
    (allocation-class ()
      :report "Use allocation :CLASS instead."
      (setq allocation :class)))
  (apply #'call-next-method slotd
         :allocation allocation
         :reinitialize
         #-(or cmu (and mcl (not openmcl)))
         (and reinitialize *reinitialize-singleton-class*)
         #+(or cmu (and mcl (not openmcl)))
         nil
         initargs))

(defmethod initialize-instance :before
  ((class singleton-class) &rest initargs)
  (when (getf initargs
              #-lispworks4 :direct-default-initargs
              #+lispworks4 :default-initargs)
    (warn "Default initialization arguments do not make sense for singleton class ~S." class)))

(defmethod reinitialize-instance :before
  ((class singleton-class) &rest initargs)
  (when (getf initargs
              #-lispworks4 :direct-default-initargs
              #+lispworks4 :default-initargs)
    (warn "Default initialization arguments do not make sense for singleton class ~S." class)))

(defmethod reinitialize-instance :after
  ((class singleton-class) &key)
  (when-let (prototype (ignore-errors (class-prototype class)))
    (loop for slot in (class-direct-slots class)
          when (slot-definition-reinitializep slot) do
          (setf (slot-definition-reinitializep slot) nil)
          (if (slot-definition-initfunction slot)
            (setf (slot-value prototype (slot-definition-name slot))
                  (funcall (slot-definition-initfunction slot)))
            (slot-makunbound prototype (slot-definition-name slot))))))

(defmethod finalize-inheritance :after ((class singleton-class))
  (let ((prototype (class-prototype class)))
    (loop for slot in (class-direct-slots class)
          when (slot-definition-reinitializep slot) do
          (setf (slot-definition-reinitializep slot) nil)
          (if (slot-definition-initfunction slot)
            (setf (slot-value prototype (slot-definition-name slot))
                  (funcall (slot-definition-initfunction slot)))
            (slot-makunbound prototype (slot-definition-name slot))))))

(declaim (inline find-singleton))

(defun find-singleton (name &optional (errorp t) environment)
  (class-prototype (find-class name errorp environment)))