/usr/share/common-lisp/source/closer-mop/closer-allegro.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 | (in-package :closer-mop)
;; We need a new standard-class for various things.
(defclass standard-class (cl:standard-class excl:lockable-object)
((valid-slot-allocations :initform '(:instance :class)
:accessor valid-slot-allocations
:reader excl::valid-slot-allocation-list)))
(define-validate-superclass-method standard-class cl:standard-class)
;; Allegro defines an extra check for :allocation kinds. AMOP expects any kind to be
;; permissible, though. This is corrected here.
(cl:defmethod direct-slot-definition-class :before ((class standard-class) &key allocation &allow-other-keys)
(unless (eq (class-of class) (find-class 'standard-class))
(excl:with-locked-object
(class :non-smp :without-scheduling)
(pushnew allocation (valid-slot-allocations class)))))
;;; In Allegro, slot-boundp-using-class and slot-makunbound-using-class are specialized
;;; on slot names instead of effective slot definitions. In order to fix this,
;;; we need to rewire the slot access protocol.
#-(version>= 8 1)
(progn
(cl:defmethod slot-boundp-using-class
((class standard-class) object (slot symbol))
(declare (optimize (speed 3) (debug 0) (safety 0)
(compilation-speed 0)))
(let ((slotd (find slot (class-slots class)
:test #'eq
:key #'slot-definition-name)))
(if slotd
(slot-boundp-using-class class object slotd)
(slot-missing class object slot 'slot-boundp))))
(cl:defmethod slot-boundp-using-class
((class standard-class) object (slotd standard-effective-slot-definition))
(declare (optimize (speed 3) (debug 0) (safety 0)
(compilation-speed 0)))
(slot-boundp-using-class
(load-time-value (class-prototype (find-class 'cl:standard-class)))
object
(slot-definition-name slotd))))
(cl:defmethod slot-makunbound-using-class
((class standard-class) object (slot symbol))
(declare (optimize (speed 3) (debug 0) (safety 0)
(compilation-speed 0)))
(let ((slotd (find slot (class-slots class)
:test #'eq
:key #'slot-definition-name)))
(if slotd
(slot-makunbound-using-class class object slotd)
(slot-missing class object slot 'slot-makunbound))))
(cl:defmethod slot-makunbound-using-class
((class standard-class) object (slotd standard-effective-slot-definition))
(declare (optimize (speed 3) (debug 0) (safety 0)
(compilation-speed 0)))
(slot-makunbound-using-class
(load-time-value (class-prototype (find-class 'cl:standard-class)))
object
(slot-definition-name slotd)))
;;; New generic functions.
(cl:defmethod initialize-instance :around
((gf standard-generic-function) &rest initargs &key (method-class nil method-class-p))
(declare (dynamic-extent initargs))
(if (and method-class-p (symbolp method-class))
(apply #'call-next-method gf
:method-class (find-class method-class)
initargs)
(call-next-method)))
(cl:defmethod reinitialize-instance :around
((gf standard-generic-function) &rest initargs &key (method-class nil method-class-p))
(declare (dynamic-extent initargs))
(if (and method-class-p (symbolp method-class))
(apply #'call-next-method gf
:method-class (find-class method-class)
initargs)
(call-next-method)))
;;; The following three methods ensure that the dependent protocol
;;; for generic function works.
;; The following method additionally ensures that
;; compute-discriminating-function is triggered.
(cl:defmethod reinitialize-instance :after
((gf standard-generic-function) &rest initargs)
(declare (dynamic-extent initargs))
(set-funcallable-instance-function gf (compute-discriminating-function gf))
(map-dependents gf (lambda (dep) (apply #'update-dependent gf dep initargs))))
(cl:defmethod add-method :after
((gf standard-generic-function) method)
(map-dependents gf (lambda (dep) (update-dependent gf dep 'add-method method))))
(cl:defmethod remove-method :after
((gf standard-generic-function) method)
(map-dependents gf (lambda (dep) (update-dependent gf dep 'remove-method method))))
;; The following method ensures that we get only the required arguments
;; from generic-function-argument-precedence-order
(cl:defgeneric generic-function-argument-precedence-order (gf)
(:method ((gf generic-function))
(required-args (mop:generic-function-argument-precedence-order gf))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(pushnew :closer-mop *features*))
|