/usr/share/common-lisp/source/contextl/cx-layered-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 | (in-package :contextl)
(defclass special-layered-access-class
(layered-access-class special-class standard-class-in-layer)
())
(defclass special-layered-direct-slot-definition
(layered-direct-slot-definition
special-direct-slot-definition
standard-direct-slot-definition-in-layer)
())
(defclass special-effective-slot-definition-in-layers
(special-effective-slot-definition
standard-effective-slot-definition-in-layers)
())
(defclass layered-effective-slot-definition-in-layers
(layered-effective-slot-definition
standard-effective-slot-definition-in-layers)
())
(defclass special-layered-effective-slot-definition
(layered-effective-slot-definition-in-layers
special-effective-slot-definition-in-layers)
())
(defmethod direct-slot-definition-class
((class special-layered-access-class) &key &allow-other-keys)
(find-class 'special-layered-direct-slot-definition))
(defvar *special-layered-effective-slot-definition-class*)
(defmethod effective-slot-definition-class
((class special-layered-access-class) &key &allow-other-keys)
(if *special-layered-effective-slot-definition-class*
*special-layered-effective-slot-definition-class*
(call-next-method)))
(defmethod compute-effective-slot-definition
((class special-layered-access-class) name direct-slot-definitions)
(declare (ignore name))
(let ((*special-layered-effective-slot-definition-class*
(if (some #'slot-definition-layeredp direct-slot-definitions)
(if (some #'slot-definition-specialp direct-slot-definitions)
(find-class 'special-layered-effective-slot-definition)
(find-class 'layered-effective-slot-definition-in-layers))
(when (some #'slot-definition-specialp direct-slot-definitions)
(find-class 'special-effective-slot-definition-in-layers)))))
(call-next-method)))
(defclass layered-class (partial-class special-layered-access-class)
()
(:default-initargs :defining-metaclass 'special-layered-access-class))
#+sbcl
(defmethod shared-initialize :after
((class layered-class) slot-names &key defining-metaclass)
(declare (ignore slot-names defining-metaclass)))
(defmacro define-layered-class (&whole form name &body options)
(let* ((layer (if (member (car options) '(:in-layer :in) :test #'eq)
(cadr options)
t))
(options (cond ((member (car options) '(:in-layer :in) :test #'eq)
(cddr options))
((not (listp (car options)))
(error "Illegal option ~S in ~S."
(car options) form))
(t options)))
(form `(defclass ,name ,(car options)
,(mapcar #'process-layered-access-slot-specification (cadr options))
,@(cddr options)
,@(unless (assoc :metaclass options)
'((:metaclass layered-class)))
(:in-layer . ,layer))))
#+allegro (if (eq (find-layer layer nil) 't) form
`(excl:without-redefinition-warnings ,form))
#+lispworks (if (eq (find-layer layer nil) 't) form
`(let ((dspec:*redefinition-action* :quiet)) ,form))
#-(or allegro lispworks) form))
|