/usr/share/common-lisp/source/closer-mop/closer-clozure.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 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 | (in-package :closer-mop)
(defclass standard-class (cl:standard-class) ())
(define-validate-superclass-method standard-class cl:standard-class)
(cl:defmethod reinitialize-instance :after ((class standard-class) &key)
(finalize-inheritance class))
;;; New generic functions.
;; Store the method function somewhere else, to circumvent
;; the native check for congruent lambda lists.
(defparameter *stub-method-functions* (make-hash-table :test #'equal))
(defun get-stub-method-function (lambda-list)
(or (gethash lambda-list *stub-method-functions*)
(let ((ignore-list (loop for arg in lambda-list
unless (member arg lambda-list-keywords)
collect (etypecase arg
(symbol arg)
(cons (etypecase (car arg)
(symbol (car arg))
(cons (assert (cdr arg))
(cadr arg))))))))
(setf (gethash lambda-list *stub-method-functions*)
(compile nil `(lambda ,lambda-list
(declare (ignore ,@ignore-list))
(error "This method function must not be called.")))))))
(cl:defmethod initialize-instance :around
((method standard-method) &rest initargs &key lambda-list function closer-patch)
(if closer-patch
(apply #'call-next-method method
:real-function function
:function (get-stub-method-function lambda-list)
initargs)
(apply #'call-next-method method
:real-function function
initargs)))
;; Adapt argument-precedence-order whenever the lambda list changes.
(cl:defmethod reinitialize-instance :around
((gf standard-generic-function) &rest initargs &key
(lambda-list '() lambda-list-p)
(argument-precedence-order '() argument-precedence-order-p))
(declare (dynamic-extent initargs)
(ignore argument-precedence-order))
(if (and lambda-list-p (not argument-precedence-order-p))
(apply #'call-next-method gf
:argument-precedence-order (required-args lambda-list)
initargs)
(call-next-method)))
;; Ensure that the discriminating function is computed and installed
;; at the moments in time as stated in the CLOS MOP specification.
(cl:defmethod add-method :after ((gf standard-generic-function) method)
(declare (ignore method))
(set-funcallable-instance-function gf (compute-discriminating-function gf)))
(cl:defmethod remove-method :after ((gf standard-generic-function) method)
(declare (ignore method))
(set-funcallable-instance-function gf (compute-discriminating-function gf)))
(cl:defmethod initialize-instance :after ((gf standard-generic-function) &key)
(set-funcallable-instance-function gf (compute-discriminating-function gf)))
(cl:defmethod reinitialize-instance :after ((gf standard-generic-function) &key)
(set-funcallable-instance-function gf (compute-discriminating-function gf)))
;; Define compute-effective-method correctly.
(cl:defmethod compute-effective-method ((gf standard-generic-function)
(combination ccl:standard-method-combination)
methods)
(declare (optimize (speed 3) (space 0) (compilation-speed 0)))
(loop for method in methods
for qualifiers = (method-qualifiers method)
if (equal qualifiers '()) collect method into primary
else if (equal qualifiers '(:before)) collect method into before
else if (equal qualifiers '(:after)) collect method into after
else if (equal qualifiers '(:around)) collect method into around
else do (invalid-method-error method "Invalid method qualifiers ~S." qualifiers)
finally
(unless primary (method-combination-error "No primary method."))
(let ((form (if (or before after (rest primary))
`(multiple-value-prog1
(progn ,@(loop for method in before collect `(call-method ,method))
(call-method ,(first primary) ,(rest primary)))
,@(loop for method in (reverse after) collect `(call-method ,method)))
`(call-method ,(first primary)))))
(return
(if around
`(call-method ,(first around) (,@(rest around) (make-method ,form)))
form)))))
(cl:defmethod compute-effective-method ((gf standard-generic-function)
(combination ccl:short-method-combination)
methods)
(declare (optimize (speed 3) (space 0) (compilation-speed 0)))
(loop with primary-qualifiers = (list (ccl::method-combination-name combination))
for method in methods
for qualifiers in (method-qualifiers method)
if (equal qualifiers primary-qualifiers) collect method into primary
else if (equal qualifiers '(:around)) collect method into around
else do (invalid-method-error method "Invalid method qualifiers ~S." qualifiers)
finally
(unless primary (method-combination-error "No primary method."))
(when (eq (car (ccl::method-combination-options combination))
:most-specific-last)
(setq primary (nreverse primary)))
(let ((form (if (and (ccl::method-combination-identity-with-one-argument combination)
(null (rest primary)))
`(call-method ,(first primary))
`(,(ccl::method-combination-operator combination)
,@(loop for method in primary collect `(call-method ,method))))))
(return
(if around
`(call-method ,(first around) (,@(rest around) (make-method ,form)))
form)))))
(cl:defmethod compute-effective-method ((gf standard-generic-function)
(combination ccl:long-method-combination)
methods)
(declare (optimize (speed 3) (space 0) (compilation-speed 0)))
(destructuring-bind ((args-var . gf-name) . expander)
(ccl::method-combination-expander combination)
(declare (ignore args-var gf-name))
(funcall expander gf methods (ccl::method-combination-options combination))))
;; "Native" make-method-lambda.
(cl:defmethod make-method-lambda ((gf generic-function) (method method) lambda-expression environment)
(declare (ignore environment) (optimize (speed 3) (space 0) (compilation-speed 0)))
(let ((methvar (gensym)))
(values
`(lambda (ccl::&method ,methvar ,@(cadr lambda-expression))
(flet ((call-next-method (&rest args)
(declare (dynamic-extent args))
(if args
(apply #'ccl::%call-next-method-with-args ,methvar args)
(ccl::%call-next-method ,methvar)))
(next-method-p () (ccl::%next-method-p ,methvar)))
(declare (inline call-next-method next-method-p))
,@(cddr lambda-expression)))
(let ((documentation (parse-method-body (cddr lambda-expression) lambda-expression)))
(when documentation
(list :documentation documentation))))))
;; "Native" compute-discriminating-function.
(cl:defmethod compute-discriminating-function ((gf generic-function))
(let ((non-dt-dcode (ccl::non-dt-dcode-function gf)))
(if non-dt-dcode
non-dt-dcode
(let* ((std-dfun (ccl::%gf-dcode gf))
(dt (ccl::%gf-dispatch-table gf))
(proto (cdr (assoc std-dfun ccl::dcode-proto-alist))))
(if (or (eq proto #'ccl::gag-one-arg)
(eq proto #'ccl::gag-two-arg))
(lambda (&rest args)
(declare (dynamic-extent args))
(apply std-dfun dt args))
(lambda (&rest args)
(declare (dynamic-extent args))
(funcall std-dfun dt args)))))))
;; The following ensures that slot definitions have a documentation.
(cl:defmethod documentation ((slot slot-definition) (type (eql 't)))
(ccl:slot-definition-documentation slot))
(eval-when (:compile-toplevel :load-toplevel :execute)
(pushnew :closer-mop *features*))
|