/usr/share/common-lisp/source/contextl/cx-singleton-class.lisp is in cl-contextl 1:0.61-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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 | (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 ecl) (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 ecl) (and reinitialize *reinitialize-singleton-class*)
#+(or cmu ecl) nil
initargs))
(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)))
|