/usr/share/common-lisp/source/closer-mop/closer-cmu.lisp is in cl-closer-mop 2:0.6-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 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 | (in-package :closer-mop)
;; In CMUCL, reader-method-class and writer-method-class are
;; not used during class initialization. The following definitions
;; correct this.
(defun modify-accessors (class)
(loop with reader-specializers = (list class)
with writer-specializers = (list (find-class 't) class)
for slotd in (class-direct-slots class) do
(loop for reader in (slot-definition-readers slotd)
for reader-function = (fdefinition reader)
for reader-method = (find-method reader-function () reader-specializers)
for initargs = (list :qualifiers ()
:lambda-list '(object)
:specializers reader-specializers
:function (method-function reader-method)
:slot-definition slotd)
for method-class = (apply #'reader-method-class class slotd initargs)
unless (eq method-class (class-of reader-method))
do (add-method reader-function (apply #'make-instance method-class initargs)))
(loop for writer in (slot-definition-writers slotd)
for writer-function = (fdefinition writer)
for writer-method = (find-method writer-function () writer-specializers)
for initargs = (list :qualifiers ()
:lambda-list '(new-value object)
:specializers writer-specializers
:function (method-function writer-method)
:slot-definition slotd)
for method-class = (apply #'writer-method-class class slotd initargs)
unless (eq method-class (class-of writer-method))
do (add-method writer-function (apply #'make-instance method-class initargs)))))
;; The following methods additionally create a gensym for the class name
;; unless a name is explicitly provided. AMOP requires classes to be
;; potentially anonymous.
(defmethod initialize-instance :around
((class standard-class) &rest initargs
&key (name (gensym)))
(declare (dynamic-extent initargs))
(prog1 (apply #'call-next-method class :name name initargs)
(modify-accessors class)))
(defmethod initialize-instance :around
((class funcallable-standard-class) &rest initargs
&key (name (gensym)))
(declare (dynamic-extent initargs))
(prog1 (apply #'call-next-method class :name name initargs)
(modify-accessors class)))
(defmethod reinitialize-instance :after
((class standard-class) &key)
(modify-accessors class))
(defmethod reinitialize-instance :after
((class funcallable-standard-class) &key)
(modify-accessors class))
;;; The following three methods ensure that the dependent protocol
;;; for generic function works.
;; The following method additionally ensures that
;; compute-discriminating-function is triggered.
; Note that for CMUCL, these methods violate the AMOP specification
; by specializing on the original standard-generic-function metaclass. However,
; this is necassary because in CMUCL, only one subclass of
; standard-generic-function can be created, and taking away that option from user
; code doesn't make a lot of sense in our context.
(defmethod reinitialize-instance :after
((gf standard-generic-function) &rest initargs)
(declare (dynamic-extent initargs))
(set-funcallable-instance-function gf (compute-discriminating-function gf)))
;; The following ensures that effective slot definitions have a documentation in CMUCL.
(defmethod compute-effective-slot-definition :around
((class standard-class) name direct-slot-definitions)
(let ((effective-slot (call-next-method)))
(loop for direct-slot in direct-slot-definitions
for documentation = (documentation direct-slot 't)
when documentation do
(setf (documentation effective-slot 't) documentation)
(loop-finish))
effective-slot))
;; In CMUCL, TYPEP and SUBTYPEP don't work as expected
;; in conjunction with class metaobjects.
(defgeneric typep (object type)
(:method (object type)
(cl:typep object type))
(:method (object (type class))
(cl:typep object (class-name type))))
(defgeneric subtypep (type1 type2)
(:method (type1 type2)
(cl:subtypep type1 type2))
(:method ((type1 class) type2)
(cl:subtypep (class-name type1) type2))
(:method (type1 (type2 class))
(cl:subtypep type1 (class-name type2)))
(:method ((type1 class) (type2 class))
(cl:subtypep (class-name type1)
(class-name type2))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(pushnew :closer-mop *features*))
|