/usr/share/common-lisp/source/contextl/cx-partial-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 80 81 82 83 84 85 86 | (in-package :contextl)
(defclass partial-object (standard-object)
()
(:default-initargs :allow-other-keys t))
(defclass partial-class (standard-class)
((defining-classes :initarg defining-classes
:reader partial-class-defining-classes)
(defining-metaclass :initarg :defining-metaclass
:reader partial-class-defining-metaclass)))
(defmethod validate-superclass
((class partial-class)
(superclass standard-class))
t)
(defmethod validate-superclass
((class standard-class)
(superclass partial-class))
t)
#+allegro
(defmethod finalize-inheritance :after ((class partial-class))
(mapc #'finalize-inheritance (rest (class-precedence-list class))))
(defmethod initialize-instance :around
((class partial-class) &rest initargs
&key name
(in-layer 't in-layer-p) (in 't in-p)
(defining-metaclass 'standard-class))
(declare (dynamic-extent initargs))
(assert (not (and in-layer-p in-p)))
(let* ((in-layer (if in-layer-p in-layer in))
(in-layer-name (or (layer-name in-layer) (find-layer in-layer)))
(direct-superclasses (list (find-class 'partial-object)))
(defining-classes ()))
(let ((defined-class
(apply #'make-instance defining-metaclass
(loop for (key value) on initargs by #'cddr
unless (member key '(:name :defining-metaclass))
nconc (list key value)))))
(push defined-class direct-superclasses)
(setf (getf defining-classes in-layer-name) defined-class))
(unless (eq in-layer-name 't)
(let ((defined-class (make-instance defining-metaclass)))
(push defined-class direct-superclasses)
(setf (getf defining-classes 't) defined-class)))
(call-next-method class
:name name
:direct-superclasses direct-superclasses
'defining-classes defining-classes
:defining-metaclass defining-metaclass)))
(defmethod reinitialize-instance :around
((class partial-class) &rest initargs
&key (in-layer 't in-layer-p) (in 't in-p)
(defining-metaclass (partial-class-defining-metaclass class) defining-metaclass-p))
(declare (dynamic-extent initargs))
(assert (not (and in-layer-p in-p)))
(let* ((in-layer (if in-layer-p in-layer in))
(in-layer-name (or (layer-name in-layer) (find-layer in-layer))))
(let ((defined-class (getf (partial-class-defining-classes class) in-layer-name)))
(if defined-class
(progn
(apply #'reinitialize-instance defined-class
(loop for (key value) on initargs by #'cddr
unless (member key '(:name :defining-metaclass))
nconc (list key value)))
(call-next-method class))
(let ((defined-class
(apply #'make-instance defining-metaclass
(loop for (key value) on initargs by #'cddr
unless (member key '(:name :defining-metaclass))
nconc (list key value)))))
(apply #'call-next-method class
:direct-superclasses
(append (remove (find-class 'partial-object)
(class-direct-superclasses class))
(list defined-class)
(list (find-class 'partial-object)))
'defining-classes
(list* in-layer-name defined-class
(partial-class-defining-classes class))
(when defining-metaclass-p
(list :defining-metaclass defining-metaclass))))))))
|