├── closer-abcl.lisp ├── closer-clisp.lisp ├── closer-mezzano.lisp ├── closer-sbcl.lisp ├── closer-mop-system.cl ├── closer-ecl.lisp ├── closer-clasp.lisp ├── LICENSE.md ├── closer-mop.asd ├── closer-mcl.lisp ├── closer-scl.lisp ├── closer-allegro.lisp ├── closer-cmu.lisp ├── README.md ├── closer-clozure.lisp ├── closer-mop-packages.lisp ├── closer-lispworks.lisp ├── features.txt ├── features.lisp └── closer-mop-shared.lisp /closer-abcl.lisp: -------------------------------------------------------------------------------- 1 | (in-package :closer-mop) 2 | 3 | (eval-when (:compile-toplevel :load-toplevel :execute) 4 | (pushnew :closer-mop *features*)) 5 | -------------------------------------------------------------------------------- /closer-clisp.lisp: -------------------------------------------------------------------------------- 1 | (in-package :closer-mop) 2 | 3 | (eval-when (:compile-toplevel :load-toplevel :execute) 4 | (pushnew :closer-mop *features*)) 5 | -------------------------------------------------------------------------------- /closer-mezzano.lisp: -------------------------------------------------------------------------------- 1 | (in-package :closer-mop) 2 | 3 | (eval-when (:compile-toplevel :load-toplevel :execute) 4 | (pushnew :closer-mop *features*)) 5 | -------------------------------------------------------------------------------- /closer-sbcl.lisp: -------------------------------------------------------------------------------- 1 | (in-package :closer-mop) 2 | 3 | (eval-when (:compile-toplevel :load-toplevel :execute) 4 | (pushnew :closer-mop *features*)) 5 | -------------------------------------------------------------------------------- /closer-mop-system.cl: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | #| 4 | :name "Closer to MOP" 5 | :author "Pascal Costanza" 6 | :version "1.0.0" 7 | :licence "MIT-style license" 8 | |# 9 | 10 | (defsystem :closer-mop () 11 | (:serial 12 | "closer-mop-packages" 13 | "closer-mop-shared" 14 | "closer-allegro")) 15 | -------------------------------------------------------------------------------- /closer-ecl.lisp: -------------------------------------------------------------------------------- 1 | (in-package :closer-mop) 2 | 3 | (cl:defmethod compute-effective-method-function ((gf standard-generic-function) effective-method options) 4 | (declare (optimize (speed 3) (space 0) (compilation-speed 0))) 5 | (when options 6 | (cerror "Ignore these options." 7 | "This version of compute-effective-method-function does not support method combination options: ~S" 8 | options)) 9 | (coerce `(lambda (&rest clos:.combined-method-args.) 10 | (declare (special clos:.combined-method-args. clos:*next-methods*)) 11 | ,effective-method) 12 | 'function)) 13 | 14 | (declaim (inline eql-specializer-p)) 15 | (defun eql-specializer-p (thing) 16 | (typep thing 'eql-specializer)) 17 | 18 | (eval-when (:compile-toplevel :load-toplevel :execute) 19 | (pushnew :closer-mop *features*)) 20 | -------------------------------------------------------------------------------- /closer-clasp.lisp: -------------------------------------------------------------------------------- 1 | (in-package :closer-mop) 2 | 3 | ;; TODO FIXME this below is untested 4 | (cl:defmethod compute-effective-method-function ((gf standard-generic-function) effective-method options) 5 | (declare (optimize (speed 3) (space 0) (compilation-speed 0))) 6 | (when options 7 | (cerror "Ignore these options." 8 | "This version of compute-effective-method-function does not support method combination options: ~S" 9 | options)) 10 | (coerce `(lambda (.method-args. .next-methods. &rest passed-arguments) 11 | ,effective-method) 12 | 'function) 13 | ;; alternatively 14 | #+nil 15 | (coerce `(lambda (dummy-method-args .next-methods. &va-rest .method-args.) 16 | ,effective-method) 17 | 'function)) 18 | 19 | (declaim (inline eql-specializer-p)) 20 | (defun eql-specializer-p (thing) 21 | (typep thing 'eql-specializer)) 22 | 23 | (eval-when (:compile-toplevel :load-toplevel :execute) 24 | (pushnew :closer-mop *features*)) 25 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2005 - 2016 Pascal Costanza 2 | 3 | Permission is hereby granted, free of charge, to any person 4 | obtaining a copy of this software and associated documentation 5 | files (the "Software"), to deal in the Software without 6 | restriction, including without limitation the rights to use, 7 | copy, modify, merge, publish, distribute, sublicense, and/or 8 | sell copies of the Software, and to permit persons to whom the 9 | Software is furnished to do so, subject to the following 10 | conditions: 11 | 12 | The above copyright notice and this permission notice shall be 13 | included in all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 16 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 17 | OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 18 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 19 | HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 20 | WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 21 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. 23 | -------------------------------------------------------------------------------- /closer-mop.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem #:closer-mop 2 | :name "Closer to MOP" 3 | :description "Closer to MOP is a compatibility layer that rectifies many of the absent or incorrect CLOS MOP features across a broad range of Common Lisp implementations." 4 | :author "Pascal Costanza" 5 | :version "1.0.0" 6 | :licence "MIT-style license" 7 | :serial t 8 | :components 9 | ((:file "closer-mop-packages") 10 | (:file "closer-mop-shared") 11 | #+clisp 12 | (:file "closer-clisp") 13 | #-clisp 14 | (:module "implementation" 15 | :pathname "" 16 | :components 17 | ((:file "closer-abcl" :if-feature :abcl) 18 | (:file "closer-allegro" :if-feature :allegro) 19 | (:file "closer-clasp" :if-feature :clasp) 20 | (:file "closer-clisp" :if-feature :clisp) 21 | (:file "closer-clozure" :if-feature :clozure) 22 | (:file "closer-cmu" :if-feature :cmu) 23 | (:file "closer-ecl" :if-feature :ecl) 24 | (:file "closer-lispworks" :if-feature :lispworks) 25 | (:file "closer-mcl" :if-feature :mcl) 26 | (:file "closer-mezzano" :if-feature :mezzano) 27 | (:file "closer-sbcl" :if-feature :sbcl) 28 | (:file "closer-scl" :if-feature :scl))))) 29 | -------------------------------------------------------------------------------- /closer-mcl.lisp: -------------------------------------------------------------------------------- 1 | (in-package :closer-mop) 2 | 3 | ;; We need a new standard-class for various things. 4 | 5 | (defclass standard-class (cl:standard-class) ()) 6 | (define-validate-superclass-method standard-class cl:standard-class) 7 | 8 | (defmethod ccl::create-reader-method-function 9 | ((class standard-class) 10 | (reader-method-class standard-reader-method) 11 | (dslotd standard-direct-slot-definition)) 12 | (let ((slot-name (slot-definition-name dslotd))) 13 | (compile nil `(lambda (object) (slot-value object ',slot-name))))) 14 | 15 | (defmethod ccl::create-writer-method-function 16 | ((class standard-class) 17 | (writer-method-class standard-writer-method) 18 | (dslotd standard-direct-slot-definition)) 19 | (let ((slot-name (slot-definition-name dslotd))) 20 | (compile nil `(lambda (new-value object) 21 | (setf (slot-value object ',slot-name) new-value))))) 22 | 23 | (defgeneric typep (object type) 24 | (:method (object type) 25 | (cl:typep object type)) 26 | (:method (object (type class)) 27 | (member (class-of object) 28 | (class-precedence-list type)))) 29 | 30 | (defgeneric subtypep (type1 type2) 31 | (:method (type1 type2) 32 | (cl:subtypep type1 type2)) 33 | (:method ((type1 class) (type2 symbol)) 34 | (let ((class2 (find-class type2 nil))) 35 | (if class2 36 | (member class2 (class-precedence-list type1)) 37 | (cl:subtypep type1 type2)))) 38 | (:method ((type1 symbol) (type2 class)) 39 | (let ((class1 (find-class type1 nil))) 40 | (if class1 41 | (member type2 (class-precedence-list class1)) 42 | (cl:subtypep type1 type2)))) 43 | (:method ((type1 class) (type2 class)) 44 | (member type2 (class-precedence-list type1)))) 45 | 46 | (eval-when (:compile-toplevel :load-toplevel :execute) 47 | (pushnew :closer-mop *features*)) 48 | -------------------------------------------------------------------------------- /closer-scl.lisp: -------------------------------------------------------------------------------- 1 | (in-package :closer-mop) 2 | 3 | (defgeneric add-direct-method (specializer method) 4 | (:method ((specializer standard-object) (method method)))) 5 | 6 | (defgeneric remove-direct-method (specializer method) 7 | (:method ((specializer standard-object) (method method)))) 8 | 9 | (defvar *dependents* (make-hash-table :test #'eq)) 10 | 11 | (defgeneric add-dependent (metaobject dependent) 12 | (:method ((metaobject standard-class) dependent) 13 | (pushnew dependent (gethash metaobject *dependents*))) 14 | (:method ((metaobject funcallable-standard-class) dependent) 15 | (pushnew dependent (gethash metaobject *dependents*))) 16 | (:method ((metaobject standard-generic-function) dependent) 17 | (pushnew dependent (gethash metaobject *dependents*)))) 18 | 19 | (defgeneric remove-dependent (metaobject dependent) 20 | (:method ((metaobject standard-class) dependent) 21 | (setf (gethash metaobject *dependents*) 22 | (delete metaobject (gethash metaobject *dependents*)))) 23 | (:method ((metaobject funcallable-standard-class) dependent) 24 | (setf (gethash metaobject *dependents*) 25 | (delete metaobject (gethash metaobject *dependents*)))) 26 | (:method ((metaobject standard-generic-function) dependent) 27 | (setf (gethash metaobject *dependents*) 28 | (delete metaobject (gethash metaobject *dependents*))))) 29 | 30 | (defgeneric map-dependents (metaobject function) 31 | (:method ((metaobject standard-class) function) 32 | (mapc function (gethash metaobject *dependents*))) 33 | (:method ((metaobject funcallable-standard-class) function) 34 | (mapc function (gethash metaobject *dependents*))) 35 | (:method ((metaobject standard-generic-function) function) 36 | (mapc function (gethash metaobject *dependents*)))) 37 | 38 | (defgeneric update-dependent (metaobject dependent &rest initargs)) 39 | 40 | (defmethod reinitialize-instance :after ((metaobject metaobject) &rest initargs) 41 | (map-dependents metaobject (lambda (dep) (apply #'update-dependent metaobject dep initargs)))) 42 | 43 | (defmethod add-method :after 44 | ((gf standard-generic-function) method) 45 | (loop for specializer in (method-specializers method) 46 | do (add-direct-method specializer method)) 47 | (map-dependents gf (lambda (dep) (update-dependent gf dep 'add-method method)))) 48 | 49 | (defmethod remove-method :after 50 | ((gf standard-generic-function) method) 51 | (loop for specializer in (method-specializers method) 52 | do (remove-direct-method specializer method)) 53 | (map-dependents gf (lambda (dep) (update-dependent gf dep 'remove-method method)))) 54 | 55 | (eval-when (:compile-toplevel :load-toplevel :execute) 56 | (pushnew :closer-mop *features*)) 57 | -------------------------------------------------------------------------------- /closer-allegro.lisp: -------------------------------------------------------------------------------- 1 | (in-package :closer-mop) 2 | 3 | ;; We need a new standard-class for various things. 4 | 5 | (defclass standard-class (cl:standard-class excl:lockable-object) 6 | ((valid-slot-allocations :initform '(:instance :class) 7 | :accessor valid-slot-allocations 8 | :reader excl::valid-slot-allocation-list))) 9 | 10 | (define-validate-superclass-method standard-class cl:standard-class) 11 | 12 | ;; Allegro defines an extra check for :allocation kinds. AMOP expects any kind to be 13 | ;; permissible, though. This is corrected here. 14 | 15 | (cl:defmethod direct-slot-definition-class :before ((class standard-class) &key allocation &allow-other-keys) 16 | (unless (eq (class-of class) (find-class 'standard-class)) 17 | (excl:with-locked-object 18 | (class :non-smp :without-scheduling) 19 | (pushnew allocation (valid-slot-allocations class))))) 20 | 21 | ;;; In Allegro, slot-boundp-using-class and slot-makunbound-using-class are specialized 22 | ;;; on slot names instead of effective slot definitions. In order to fix this, 23 | ;;; we need to rewire the slot access protocol. 24 | 25 | #-(version>= 8 1) 26 | (progn 27 | (cl:defmethod slot-boundp-using-class 28 | ((class standard-class) object (slot symbol)) 29 | (declare (optimize (speed 3) (debug 0) (safety 0) 30 | (compilation-speed 0))) 31 | (let ((slotd (find slot (class-slots class) 32 | :test #'eq 33 | :key #'slot-definition-name))) 34 | (if slotd 35 | (slot-boundp-using-class class object slotd) 36 | (slot-missing class object slot 'slot-boundp)))) 37 | 38 | (cl:defmethod slot-boundp-using-class 39 | ((class standard-class) object (slotd standard-effective-slot-definition)) 40 | (declare (optimize (speed 3) (debug 0) (safety 0) 41 | (compilation-speed 0))) 42 | (slot-boundp-using-class 43 | (load-time-value (class-prototype (find-class 'cl:standard-class))) 44 | object 45 | (slot-definition-name slotd)))) 46 | 47 | (cl:defmethod slot-makunbound-using-class 48 | ((class standard-class) object (slot symbol)) 49 | (declare (optimize (speed 3) (debug 0) (safety 0) 50 | (compilation-speed 0))) 51 | (let ((slotd (find slot (class-slots class) 52 | :test #'eq 53 | :key #'slot-definition-name))) 54 | (if slotd 55 | (slot-makunbound-using-class class object slotd) 56 | (slot-missing class object slot 'slot-makunbound)))) 57 | 58 | (cl:defmethod slot-makunbound-using-class 59 | ((class standard-class) object (slotd standard-effective-slot-definition)) 60 | (declare (optimize (speed 3) (debug 0) (safety 0) 61 | (compilation-speed 0))) 62 | (slot-makunbound-using-class 63 | (load-time-value (class-prototype (find-class 'cl:standard-class))) 64 | object 65 | (slot-definition-name slotd))) 66 | 67 | ;;; New generic functions. 68 | 69 | (cl:defmethod initialize-instance :around 70 | ((gf standard-generic-function) &rest initargs &key (method-class nil method-class-p)) 71 | (if (and method-class-p (symbolp method-class)) 72 | (apply #'call-next-method gf 73 | :method-class (find-class method-class) 74 | initargs) 75 | (call-next-method))) 76 | 77 | (cl:defmethod reinitialize-instance :around 78 | ((gf standard-generic-function) &rest initargs &key (method-class nil method-class-p)) 79 | (if (and method-class-p (symbolp method-class)) 80 | (apply #'call-next-method gf 81 | :method-class (find-class method-class) 82 | initargs) 83 | (call-next-method))) 84 | 85 | ;;; The following three methods ensure that the dependent protocol 86 | ;;; for generic function works. 87 | 88 | ;; The following method additionally ensures that 89 | ;; compute-discriminating-function is triggered. 90 | 91 | (cl:defmethod reinitialize-instance :after 92 | ((gf standard-generic-function) &rest initargs) 93 | (set-funcallable-instance-function gf (compute-discriminating-function gf)) 94 | (map-dependents gf (lambda (dep) (apply #'update-dependent gf dep initargs)))) 95 | 96 | (cl:defmethod add-method :after 97 | ((gf standard-generic-function) method) 98 | (map-dependents gf (lambda (dep) (update-dependent gf dep 'add-method method)))) 99 | 100 | (cl:defmethod remove-method :after 101 | ((gf standard-generic-function) method) 102 | (map-dependents gf (lambda (dep) (update-dependent gf dep 'remove-method method)))) 103 | 104 | ;; The following method ensures that we get only the required arguments 105 | ;; from generic-function-argument-precedence-order 106 | 107 | (cl:defgeneric generic-function-argument-precedence-order (gf) 108 | (:method ((gf generic-function)) 109 | (required-args (mop:generic-function-argument-precedence-order gf)))) 110 | 111 | (eval-when (:compile-toplevel :load-toplevel :execute) 112 | (pushnew :closer-mop *features*)) 113 | -------------------------------------------------------------------------------- /closer-cmu.lisp: -------------------------------------------------------------------------------- 1 | (in-package :closer-mop) 2 | 3 | ;; In CMUCL, reader-method-class and writer-method-class are 4 | ;; not used during class initialization. The following definitions 5 | ;; correct this. 6 | 7 | (defun modify-accessors (class) 8 | (loop with reader-specializers = (list class) 9 | with writer-specializers = (list (find-class 't) class) 10 | for slotd in (class-direct-slots class) do 11 | (loop for reader in (slot-definition-readers slotd) 12 | for reader-function = (fdefinition reader) 13 | for reader-method = (find-method reader-function () reader-specializers) 14 | for initargs = (list :qualifiers () 15 | :lambda-list '(object) 16 | :specializers reader-specializers 17 | :function (method-function reader-method) 18 | :slot-definition slotd) 19 | for method-class = (apply #'reader-method-class class slotd initargs) 20 | unless (eq method-class (class-of reader-method)) 21 | do (add-method reader-function (apply #'make-instance method-class initargs))) 22 | (loop for writer in (slot-definition-writers slotd) 23 | for writer-function = (fdefinition writer) 24 | for writer-method = (find-method writer-function () writer-specializers) 25 | for initargs = (list :qualifiers () 26 | :lambda-list '(new-value object) 27 | :specializers writer-specializers 28 | :function (method-function writer-method) 29 | :slot-definition slotd) 30 | for method-class = (apply #'writer-method-class class slotd initargs) 31 | unless (eq method-class (class-of writer-method)) 32 | do (add-method writer-function (apply #'make-instance method-class initargs))))) 33 | 34 | ;; The following methods additionally create a gensym for the class name 35 | ;; unless a name is explicitly provided. AMOP requires classes to be 36 | ;; potentially anonymous. 37 | 38 | (defmethod initialize-instance :around 39 | ((class standard-class) &rest initargs 40 | &key (name (gensym))) 41 | (prog1 (apply #'call-next-method class :name name initargs) 42 | (modify-accessors class))) 43 | 44 | (defmethod initialize-instance :around 45 | ((class funcallable-standard-class) &rest initargs 46 | &key (name (gensym))) 47 | (prog1 (apply #'call-next-method class :name name initargs) 48 | (modify-accessors class))) 49 | 50 | (defmethod reinitialize-instance :after 51 | ((class standard-class) &key) 52 | (modify-accessors class)) 53 | 54 | (defmethod reinitialize-instance :after 55 | ((class funcallable-standard-class) &key) 56 | (modify-accessors class)) 57 | 58 | ;;; The following three methods ensure that the dependent protocol 59 | ;;; for generic function works. 60 | 61 | ;; The following method additionally ensures that 62 | ;; compute-discriminating-function is triggered. 63 | 64 | ; Note that for CMUCL, these methods violate the AMOP specification 65 | ; by specializing on the original standard-generic-function metaclass. However, 66 | ; this is necassary because in CMUCL, only one subclass of 67 | ; standard-generic-function can be created, and taking away that option from user 68 | ; code doesn't make a lot of sense in our context. 69 | 70 | (defmethod reinitialize-instance :after 71 | ((gf standard-generic-function) &rest initargs) 72 | (set-funcallable-instance-function gf (compute-discriminating-function gf))) 73 | 74 | ;; The following ensures that effective slot definitions have a documentation in CMUCL. 75 | 76 | (defmethod compute-effective-slot-definition :around 77 | ((class standard-class) name direct-slot-definitions) 78 | (let ((effective-slot (call-next-method))) 79 | (loop for direct-slot in direct-slot-definitions 80 | for documentation = (documentation direct-slot 't) 81 | when documentation do 82 | (setf (documentation effective-slot 't) documentation) 83 | (loop-finish)) 84 | effective-slot)) 85 | 86 | ;; In CMUCL, TYPEP and SUBTYPEP don't work as expected 87 | ;; in conjunction with class metaobjects. 88 | 89 | (defgeneric typep (object type) 90 | (:method (object type) 91 | (cl:typep object type)) 92 | (:method (object (type class)) 93 | (cl:typep object (class-name type)))) 94 | 95 | (defgeneric subtypep (type1 type2) 96 | (:method (type1 type2) 97 | (cl:subtypep type1 type2)) 98 | (:method ((type1 class) type2) 99 | (cl:subtypep (class-name type1) type2)) 100 | (:method (type1 (type2 class)) 101 | (cl:subtypep type1 (class-name type2))) 102 | (:method ((type1 class) (type2 class)) 103 | (cl:subtypep (class-name type1) 104 | (class-name type2)))) 105 | 106 | (eval-when (:compile-toplevel :load-toplevel :execute) 107 | (pushnew :closer-mop *features*)) 108 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Closer to MOP 2 | Closer to MOP is a compatibility layer that rectifies many of the absent or incorrect CLOS MOP features across a broad range of Common Lisp implementations. 3 | 4 | Closer to MOP is also provided by [Quicklisp](https://www.quicklisp.org/). 5 | 6 | Currently, the following Common Lisp implementations are supported: 7 | * Allegro Common Lisp 10.1 Express Edition 8 | * Armed Bear Common Lisp 1.7.1 9 | * CLisp 2.49 10 | * Clozure Common Lisp 1.11.5 11 | * CMU Common Lisp 21d 12 | * Embeddable Common Lisp 16.1.3 13 | * LispWorks 7.1.2 Hobbyist Edition 14 | * Steel Bank Common Lisp 2.0.10 15 | 16 | The following implementations were supported in the past: 17 | * Allegro Common Lisp 7.0, 8.0 - 8.2 Enterprise Editions 18 | * Allegro Common Lisp 9.0, 10.0 Express Editions 19 | * Armed Bear Common Lisp 1.1.1, 1.2.1, 1.3.0-1.3.3, 1.4.0, 1.5.0, 1.6.0, 1.6.1, 1.7.0 20 | * CLisp from 2.35 onward 21 | * Clozure Common Lisp 1.2 - 1.11, 1.11.6 22 | * CMU Common Lisp 19c-f, 20a-f, 21a-c 23 | * Embeddable Common Lisp 9.12.3, 10.3.1, 10.4.1, 11.1.1, 12.2.1, 12.12.1, 15.2.21, 15.3.7, 16.0.0, 16.1.2 24 | * LispWorks 4.3 & 4.4, Personal and Professional Editions 25 | * LispWorks 5.0.1, 5.0.2, 5.1.0 - 5.1.2 Personal and Professional Editions 26 | * LispWorks 6.0, 6.0.1 Enterprise Editions 27 | * LispWorks 6.1, 6.1.1, Professional Editions 28 | * LispWorks 6.1.1 Personal Edition 29 | * LispWorks 7.0.0 Hobbyist Edition 30 | * Macintosh Common Lisp 5.1, 5.2.1 31 | * OpenMCL 1.0 32 | * Scieneer Common Lisp 1.3.9 33 | * Steel Bank Common Lisp from 0.9.16 onward (except version 1.0.0) 34 | 35 | The respective code conditionalizations are still in the source files, so there is a good chance that they still work, especially for current or newer versions. However, there is no guarantee that this is the case, and active work for these implementations is currently on hold. 36 | 37 | New in version 1.0.0: 38 | * New version number based on semantic versioning. 39 | * Since version 0.61, support for Allegro Common Lisp 8.2 & 9.0, ABCL, and LispWorks 6.1 has been added. 40 | * ECL 12.12.1 has seen major improvements in its MOP support, and therefore also in Closer to MOP. 41 | * Several bug fixes. 42 | 43 | New in version 0.61: 44 | * Added support for LispWorks 6.0. 45 | 46 | Highlights of version 0.6: 47 | * Completely reworked support for Embeddable Common Lisp. 48 | * Resurrected support for Macintosh Common Lisp (now RMCL). 49 | * Added partial support for Scieneer Common Lisp. 50 | * Closer to MOP now recognizes and supports 9 different Common Lisp implementations! 51 | * Added improved and complete generic function invocation protocols to Clozure Common Lisp, CLisp, ECL, LispWorks and SBCL. This includes support for COMPUTE-EFFECTIVE-METHOD-FUNCTION (a piece missing in AMOP) and MAKE-METHOD-LAMBDA in all these implementations (except for ECL, where I currently cannot support MAKE-METHOD-LAMBDA). Note: in order to ensure that MAKE-METHOD-LAMBDA doesn't create surprising results (or better: surprisingly doesn't create the results you expect), it is now ensured that DEFGENERIC creates a generic function metaobject in the compilation environment (without the method definitions), and it is now checked in DEFMETHOD that such a generic function metaobject exists for the method to be defined. If such a generic function metaobject doesn't exist, a STYLE-WARNING is issued (except for SBCL, which itself already issues a STYLE-WARNING in this case). 52 | * The standard metobject definition macros and functions (DEFCLASS, DEFGENERIC, DEFMETHOD, ENSURE-CLASS, ENSURE-GENERIC-FUNCTION, etc.) sometimes forced the use of the replacement 'standard' metaobject classes of Closer to MOP (STANDARD-CLASS, STANDARD-GENERIC-FUNCTION and STANDARD-METHOD). This is now completely removed: If you don't use a :METACLASS or :GENERIC-FUNCTION-CLASS option explicitly, these defining operators will use the internal metaclasses of the respective Common Lisp implementation, under the assumption that they are usually more efficient than the replacements in Closer to MOP. If for some reason, you want to ensure to use the replacements, you have to do so explicitly. (Note: The main purpose of the replacements is to provide a common compatible basis for your own metaobject subclasses, not to be used in their own right.) 53 | * Replaced synchronization statements in Allegro and LispWorks with versions that will be compatible with their future SMP support. 54 | * In LispWorks, automatically generated slot readers and writers now only call SLOT-VALUE-USING-CLASS and (SETF SLOT-VALUE-USING-CLASS) if there are actually definitions available for them. Otherwise, they use the native optimized slot access. 55 | * Simplified and improved conditionalizations for Clozure Common Lisp and LispWorks, and removed mentions of OpenMCL (which was just the old name for Clozure Common Lisp). 56 | * Reorganized the code: Moved all package definitions into one place, moved shared code into one common file, and removed the subfolders per CL implementations. (This is mostly to make the maintainer's job easier.) 57 | * Added an Allegro-specific system definition. 58 | * Lots of small little bug fixes and improvements here and there. 59 | * Extra special thanks to Duane Rettig, Steve Haflich, and Juan Jose Garcia-Ripoll for fixing extra hard bugs in extra short amount of time. 60 | 61 | Highlights of version 0.55: 62 | * Added standard-instance-access and funcallable-standard-instance-access to LispWorks, due to popular request. 63 | * Added a utility function subclassp that is sometimes more robust than subtypep (but subtypep should be preferred whenever possible). 64 | 65 | Highlights of version 0.5: 66 | * Ensured that a defgeneric form makes a generic function metaobject available in the compile-time environment. Otherwise, defmethod may not yield a method of the correct method metaobject class. 67 | * Removed dependency on lw-compat. 68 | * Added support for compute-discriminating-function in Clozure Common Lisp and OpenMCL, based on code provided by Slava Akhmechet. 69 | * Added a classp predicate, due to Willem Broekema. 70 | 71 | Highlights of version 0.4: 72 | * Utility function REQUIRED-ARGS added for collecting the required arguments of a lambda list. 73 | * Utility function ENSURE-FINALIZED added for ensuring that a class metaobject is finalized. 74 | 75 | Closer to MOP has an asdf system definition, and is part of Quicklisp, so it should be straightforward to include it in your own projects. The package that exports the relevant symbols is called CLOSER-MOP or short C2MOP. 76 | 77 | Note that in some cases, symbols from the underlying MOP implementation or even the underlying COMMON-LISP package are shadowed in Closer to MOP. So if you use the CLOSER-MOP package you may need to shadow-import those symbols. Alternatively, you can use the packages CLOSER-COMMON-LISP and CLOSER-COMMON-LISP-USER that provide the symbols of COMMON-LISP / COMMON-LISP-USER plus the symbols of the CLOS MOP and the necessary shadow-imported symbols. 78 | 79 | If symbols from the underlying MOP implementation or the COMMON-LISP package are shadowed in Closer to MOP, if they are names for metaobject classes, they are supposed to be used primarily for subclassing. If in rare cases you want to refer to them directly, please be advised that you may need to make fine-grained distinctions between the original symbols and the shadowed symbols, depending on context. The restrictions in the CLOS MOP specification do not allow for a more convenient solution. 80 | 81 | For details on what has or has not been fixed, see the accompanying file features.txt. Please also check the comments that come with the source code. 82 | -------------------------------------------------------------------------------- /closer-clozure.lisp: -------------------------------------------------------------------------------- 1 | (in-package :closer-mop) 2 | 3 | (defclass standard-class (cl:standard-class) ()) 4 | (define-validate-superclass-method standard-class cl:standard-class) 5 | 6 | (cl:defmethod reinitialize-instance :after ((class standard-class) &key) 7 | (finalize-inheritance class)) 8 | 9 | ;;; New generic functions. 10 | 11 | ;; Store the method function somewhere else, to circumvent 12 | ;; the native check for congruent lambda lists. 13 | 14 | (defparameter *stub-method-functions* (make-hash-table :test #'equal)) 15 | 16 | (defun get-stub-method-function (lambda-list) 17 | (or (gethash lambda-list *stub-method-functions*) 18 | (let ((ignore-list (loop for arg in lambda-list 19 | unless (member arg lambda-list-keywords) 20 | collect (etypecase arg 21 | (symbol arg) 22 | (cons (etypecase (car arg) 23 | (symbol (car arg)) 24 | (cons (assert (cdr arg)) 25 | (cadr arg)))))))) 26 | (setf (gethash lambda-list *stub-method-functions*) 27 | (compile nil `(lambda ,lambda-list 28 | (declare (ignore ,@ignore-list)) 29 | (error "This method function must not be called."))))))) 30 | 31 | (cl:defmethod initialize-instance :around 32 | ((method standard-method) &rest initargs &key lambda-list function closer-patch) 33 | (if closer-patch 34 | (apply #'call-next-method method 35 | :real-function function 36 | :function (get-stub-method-function lambda-list) 37 | initargs) 38 | (apply #'call-next-method method 39 | :real-function function 40 | initargs))) 41 | 42 | ;; Adapt argument-precedence-order whenever the lambda list changes. 43 | 44 | (cl:defmethod reinitialize-instance :around 45 | ((gf standard-generic-function) &rest initargs &key 46 | (lambda-list '() lambda-list-p) 47 | (argument-precedence-order '() argument-precedence-order-p)) 48 | (declare (ignore argument-precedence-order)) 49 | (if (and lambda-list-p (not argument-precedence-order-p)) 50 | (apply #'call-next-method gf 51 | :argument-precedence-order (required-args lambda-list) 52 | initargs) 53 | (call-next-method))) 54 | 55 | ;; Ensure that the discriminating function is computed and installed 56 | ;; at the moments in time as stated in the CLOS MOP specification. 57 | 58 | (cl:defmethod add-method :after ((gf standard-generic-function) method) 59 | (declare (ignore method)) 60 | (set-funcallable-instance-function gf (compute-discriminating-function gf))) 61 | 62 | (cl:defmethod remove-method :after ((gf standard-generic-function) method) 63 | (declare (ignore method)) 64 | (set-funcallable-instance-function gf (compute-discriminating-function gf))) 65 | 66 | (cl:defmethod initialize-instance :after ((gf standard-generic-function) &key) 67 | (set-funcallable-instance-function gf (compute-discriminating-function gf))) 68 | 69 | (cl:defmethod reinitialize-instance :after ((gf standard-generic-function) &key) 70 | (set-funcallable-instance-function gf (compute-discriminating-function gf))) 71 | 72 | ;; Define compute-effective-method correctly. 73 | 74 | (cl:defmethod compute-effective-method ((gf standard-generic-function) 75 | (combination ccl:standard-method-combination) 76 | methods) 77 | (declare (optimize (speed 3) (space 0) (compilation-speed 0))) 78 | (loop for method in methods 79 | for qualifiers = (method-qualifiers method) 80 | if (equal qualifiers '()) collect method into primary 81 | else if (equal qualifiers '(:before)) collect method into before 82 | else if (equal qualifiers '(:after)) collect method into after 83 | else if (equal qualifiers '(:around)) collect method into around 84 | else do (invalid-method-error method "Invalid method qualifiers ~S." qualifiers) 85 | finally 86 | (unless primary (method-combination-error "No primary method.")) 87 | (let ((form (if (or before after (rest primary)) 88 | `(multiple-value-prog1 89 | (progn ,@(loop for method in before collect `(call-method ,method)) 90 | (call-method ,(first primary) ,(rest primary))) 91 | ,@(loop for method in (reverse after) collect `(call-method ,method))) 92 | `(call-method ,(first primary))))) 93 | (return 94 | (if around 95 | `(call-method ,(first around) (,@(rest around) (make-method ,form))) 96 | form))))) 97 | 98 | (cl:defmethod compute-effective-method ((gf standard-generic-function) 99 | (combination ccl:short-method-combination) 100 | methods) 101 | (declare (optimize (speed 3) (space 0) (compilation-speed 0))) 102 | (loop with primary-qualifiers = (list (ccl::method-combination-name combination)) 103 | for method in methods 104 | for qualifiers = (method-qualifiers method) 105 | if (equal qualifiers primary-qualifiers) collect method into primary 106 | else if (equal qualifiers '(:around)) collect method into around 107 | else do (invalid-method-error method "Invalid method qualifiers ~S." qualifiers) 108 | finally 109 | (unless primary (method-combination-error "No primary method.")) 110 | (when (eq (car (ccl::method-combination-options combination)) 111 | :most-specific-last) 112 | (setq primary (nreverse primary))) 113 | (let ((form (if (and (ccl::method-combination-identity-with-one-argument combination) 114 | (null (rest primary))) 115 | `(call-method ,(first primary)) 116 | `(,(ccl::method-combination-operator combination) 117 | ,@(loop for method in primary collect `(call-method ,method)))))) 118 | (return 119 | (if around 120 | `(call-method ,(first around) (,@(rest around) (make-method ,form))) 121 | form))))) 122 | 123 | (cl:defmethod compute-effective-method ((gf standard-generic-function) 124 | (combination ccl:long-method-combination) 125 | methods) 126 | (declare (optimize (speed 3) (space 0) (compilation-speed 0))) 127 | (destructuring-bind ((args-var . gf-name) . expander) 128 | (ccl::method-combination-expander combination) 129 | (declare (ignore args-var gf-name)) 130 | (funcall expander gf methods (ccl::method-combination-options combination)))) 131 | 132 | ;; "Native" make-method-lambda. 133 | 134 | (cl:defmethod make-method-lambda ((gf generic-function) (method method) lambda-expression environment) 135 | (declare (ignore environment) (optimize (speed 3) (space 0) (compilation-speed 0))) 136 | (multiple-value-bind (documentation declarations body) 137 | (parse-method-body (cddr lambda-expression) lambda-expression) 138 | (let ((methvar (gensym))) 139 | (values 140 | `(lambda (ccl::&method ,methvar ,@(cadr lambda-expression)) 141 | ,@(when documentation `(,documentation)) 142 | ,@(when declarations `((declare ,@declarations))) 143 | (flet ((call-next-method (&rest args) 144 | (if args 145 | (apply #'ccl::%call-next-method-with-args ,methvar args) 146 | (ccl::%call-next-method ,methvar))) 147 | (next-method-p () (ccl::%next-method-p ,methvar))) 148 | (declare (inline call-next-method next-method-p)) 149 | ,@body)) 150 | (when documentation 151 | (list :documentation documentation)))))) 152 | 153 | ;; "Native" compute-discriminating-function. 154 | 155 | (cl:defmethod compute-discriminating-function ((gf generic-function)) 156 | (let ((non-dt-dcode (ccl::non-dt-dcode-function gf))) 157 | (if non-dt-dcode 158 | non-dt-dcode 159 | (let* ((std-dfun (ccl::%gf-dcode gf)) 160 | (dt (ccl::%gf-dispatch-table gf)) 161 | (proto (cdr (assoc std-dfun ccl::dcode-proto-alist)))) 162 | (if (or (eq proto #'ccl::gag-one-arg) 163 | (eq proto #'ccl::gag-two-arg)) 164 | (lambda (&rest args) 165 | (apply std-dfun dt args)) 166 | (lambda (&rest args) 167 | (funcall std-dfun dt args))))))) 168 | 169 | ;; The following ensures that slot definitions have a documentation. 170 | 171 | (cl:defmethod documentation ((slot slot-definition) (type (eql 't))) 172 | (ccl:slot-definition-documentation slot)) 173 | 174 | (eval-when (:compile-toplevel :load-toplevel :execute) 175 | (pushnew :closer-mop *features*)) 176 | -------------------------------------------------------------------------------- /closer-mop-packages.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage #:closer-mop 4 | (:use #:common-lisp #+lispworks #:lispworks) 5 | (:nicknames #:c2mop) 6 | 7 | #+(or allegro clozure lispworks mcl) 8 | (:shadow #:standard-class) 9 | 10 | #+(or allegro clisp clozure ecl clasp lispworks sbcl) 11 | (:shadow #:defgeneric #:defmethod #:standard-generic-function) 12 | 13 | #+clozure (:shadow standard-method) 14 | 15 | #+(or cmu mcl) (:shadow #:typep subtypep) 16 | 17 | #+lispworks5.1 18 | (:import-from #:system #:with-hash-table-locked) 19 | #+(and lispworks (not (or lispworks4 lispworks5))) 20 | (:import-from #:hcl #:with-hash-table-locked) 21 | 22 | #-(or clisp scl mezzano) 23 | (:import-from 24 | #+abcl #:ext 25 | #+allegro #:excl 26 | #+clozure #:ccl 27 | #+cmu #:pcl 28 | #+ecl #:clos 29 | #+clasp #:clos 30 | #+lispworks #:clos 31 | #+mcl #:ccl 32 | #+sbcl #:sb-pcl 33 | 34 | #:classp) 35 | 36 | (:import-from 37 | #+abcl #:mop 38 | #+allegro #:mop 39 | #+clisp #:clos 40 | #+clozure #:ccl 41 | #+cmu #:clos-mop 42 | #+ecl #:clos 43 | #+clasp #:clos 44 | #+lispworks #:clos 45 | #+mcl #:ccl 46 | #+sbcl #:sb-mop 47 | #+scl #:clos 48 | #+mezzano #:mezzano.clos 49 | 50 | #:direct-slot-definition 51 | #:effective-slot-definition 52 | #-lispworks #:eql-specializer 53 | #:forward-referenced-class 54 | #-lispworks #:funcallable-standard-class 55 | #-lispworks4 #:funcallable-standard-object 56 | #:metaobject 57 | #:slot-definition 58 | #-(or lispworks4 lispworks5 scl) #:specializer 59 | #:standard-accessor-method 60 | #:standard-direct-slot-definition 61 | #:standard-effective-slot-definition 62 | #:standard-reader-method 63 | #:standard-slot-definition 64 | #:standard-writer-method 65 | 66 | #-lispworks4.3 #:accessor-method-slot-definition 67 | #-scl #:add-dependent 68 | #-scl #:add-direct-method 69 | #:add-direct-subclass 70 | #-scl #:class-default-initargs 71 | #-scl #:class-direct-default-initargs 72 | #:class-direct-slots 73 | #:class-direct-subclasses 74 | #:class-direct-superclasses 75 | #:class-finalized-p 76 | #:class-precedence-list 77 | #:class-prototype 78 | #:class-slots 79 | #-(or clozure lispworks mcl) #:compute-applicable-methods-using-classes 80 | #:compute-class-precedence-list 81 | #-(or lispworks4 lispworks5) #:compute-default-initargs 82 | #-clozure #:compute-discriminating-function 83 | #-(or clozure scl) #:compute-effective-method 84 | #:compute-effective-slot-definition 85 | #:compute-slots 86 | #:direct-slot-definition-class 87 | #:effective-slot-definition-class 88 | #:ensure-class 89 | #:ensure-class-using-class 90 | #:ensure-generic-function-using-class 91 | #-lispworks #:eql-specializer-object 92 | #:extract-lambda-list 93 | #:extract-specializer-names 94 | #:finalize-inheritance 95 | #-lispworks #:find-method-combination 96 | #-(or lispworks scl) #:funcallable-standard-instance-access 97 | #-allegro #:generic-function-argument-precedence-order 98 | #:generic-function-declarations 99 | #:generic-function-lambda-list 100 | #:generic-function-method-class 101 | #:generic-function-method-combination 102 | #:generic-function-methods 103 | #:generic-function-name 104 | #-lispworks #:intern-eql-specializer 105 | #-(or allegro clisp clozure lispworks mcl scl mezzano) #:make-method-lambda 106 | #-scl #:map-dependents 107 | #-clozure #:method-function 108 | #:method-generic-function 109 | #:method-lambda-list 110 | #:method-specializers 111 | #-lispworks4.3 #:reader-method-class 112 | #-scl #:remove-dependent 113 | #-scl #:remove-direct-method 114 | #:remove-direct-subclass 115 | #:set-funcallable-instance-function 116 | #:slot-boundp-using-class 117 | #:slot-definition-allocation 118 | #:slot-definition-initargs 119 | #:slot-definition-initform 120 | #:slot-definition-initfunction 121 | #:slot-definition-location 122 | #:slot-definition-name 123 | #:slot-definition-readers 124 | #:slot-definition-writers 125 | #:slot-definition-type 126 | #:slot-makunbound-using-class 127 | #:slot-value-using-class 128 | #-lispworks #:specializer-direct-generic-functions 129 | #:specializer-direct-methods 130 | #-lispworks #:standard-instance-access 131 | #-scl #:update-dependent 132 | #:validate-superclass 133 | #-lispworks4.3 #:writer-method-class) 134 | 135 | (:export 136 | #:built-in-class 137 | #:class 138 | #:direct-slot-definition 139 | #:effective-slot-definition 140 | #:eql-specializer 141 | #+lispworks #:eql-specializer* 142 | #:forward-referenced-class 143 | #:funcallable-standard-class 144 | #:funcallable-standard-object 145 | #:generic-function 146 | #:metaobject 147 | #:method 148 | #:method-combination 149 | #:slot-definition 150 | #:specializer 151 | #:standard-accessor-method 152 | #:standard-class 153 | #:standard-generic-function 154 | #:standard-direct-slot-definition 155 | #:standard-effective-slot-definition 156 | #:standard-method 157 | #:standard-object 158 | #:standard-reader-method 159 | #:standard-slot-definition 160 | #:standard-writer-method 161 | 162 | #:defclass 163 | #:defgeneric 164 | #:define-method-combination 165 | #:defmethod 166 | 167 | #:classp 168 | #:ensure-finalized 169 | #:ensure-method 170 | #:fix-slot-initargs 171 | #:required-args 172 | #:subclassp 173 | 174 | #:accessor-method-slot-definition 175 | #:add-dependent 176 | #:add-direct-method 177 | #:add-direct-subclass 178 | #:class-default-initargs 179 | #:class-direct-default-initargs 180 | #:class-direct-slots 181 | #:class-direct-subclasses 182 | #:class-direct-superclasses 183 | #:class-finalized-p 184 | #:class-precedence-list 185 | #:class-prototype 186 | #:class-slots 187 | #:compute-applicable-methods-using-classes 188 | #:compute-class-precedence-list 189 | #:compute-default-initargs 190 | #:compute-discriminating-function 191 | #:compute-effective-method 192 | #:compute-effective-method-function 193 | #:compute-effective-slot-definition 194 | #:compute-slots 195 | #:direct-slot-definition-class 196 | #:effective-slot-definition-class 197 | #:ensure-class 198 | #:ensure-class-using-class 199 | #:ensure-generic-function 200 | #:ensure-generic-function-using-class 201 | #:eql-specializer-object 202 | #:extract-lambda-list 203 | #:extract-specializer-names 204 | #:finalize-inheritance 205 | #:find-method-combination 206 | #:funcallable-standard-instance-access 207 | #:generic-function-argument-precedence-order 208 | #:generic-function-declarations 209 | #:generic-function-lambda-list 210 | #:generic-function-method-class 211 | #:generic-function-method-combination 212 | #:generic-function-methods 213 | #:generic-function-name 214 | #:intern-eql-specializer 215 | #+lispworks #:intern-eql-specializer* 216 | #:make-method-lambda 217 | #:map-dependents 218 | #:method-function 219 | #:method-generic-function 220 | #:method-lambda-list 221 | #:method-specializers 222 | #:reader-method-class 223 | #:remove-dependent 224 | #:remove-direct-method 225 | #:remove-direct-subclass 226 | #:set-funcallable-instance-function 227 | #:slot-boundp-using-class 228 | #:slot-definition-allocation 229 | #:slot-definition-initargs 230 | #:slot-definition-initform 231 | #:slot-definition-initfunction 232 | #:slot-definition-location 233 | #:slot-definition-name 234 | #:slot-definition-readers 235 | #:slot-definition-writers 236 | #:slot-definition-type 237 | #:slot-makunbound-using-class 238 | #:slot-value-using-class 239 | #:specializer-direct-generic-functions 240 | #:specializer-direct-methods 241 | #:standard-instance-access 242 | #:subtypep 243 | #:typep 244 | #:update-dependent 245 | #:validate-superclass 246 | #:writer-method-class 247 | 248 | #:warn-on-defmethod-without-generic-function)) 249 | 250 | (in-package :closer-mop) 251 | 252 | (macrolet ((define-closer-common-lisp-package () 253 | (loop with symbols = (nunion (loop for sym being the external-symbols of :common-lisp 254 | if (find-symbol (symbol-name sym) :c2mop) 255 | collect it 256 | else collect sym) 257 | (loop for sym being the external-symbols of :c2mop 258 | collect sym)) 259 | with map = '() 260 | for symbol in symbols do 261 | (push (symbol-name symbol) 262 | (getf map (symbol-package symbol))) 263 | finally (return 264 | `(defpackage #:closer-common-lisp 265 | (:nicknames #:c2cl) 266 | (:use) 267 | ,@(loop for (package symbols) on map by #'cddr 268 | collect `(:import-from ,(package-name package) ,@symbols)) 269 | (:export ,@(mapcar #'symbol-name symbols))))))) 270 | (define-closer-common-lisp-package)) 271 | 272 | (defpackage #:closer-common-lisp-user 273 | (:nicknames #:c2cl-user) 274 | (:use #:closer-common-lisp)) 275 | -------------------------------------------------------------------------------- /closer-lispworks.lisp: -------------------------------------------------------------------------------- 1 | (in-package :closer-mop) 2 | 3 | ;; We need a new standard-class for various things. 4 | 5 | (defclass standard-class (cl:standard-class) ()) 6 | (define-validate-superclass-method standard-class cl:standard-class) 7 | 8 | ;; We need a new funcallable-standard-class for various things. 9 | 10 | (defclass funcallable-standard-class (clos:funcallable-standard-class) ()) 11 | (define-validate-superclass-method funcallable-standard-class clos:funcallable-standard-class) 12 | 13 | #-lispworks4 14 | (cl:defmethod validate-superclass 15 | ((class funcallable-standard-class) 16 | (superclass (eql (find-class 'funcallable-standard-object)))) 17 | t) 18 | 19 | ;; We also need a new funcallable-standard-object because the default one 20 | ;; is not an instance of clos:funcallable-standard-class. 21 | 22 | #+lispworks4 23 | (defclass funcallable-standard-object (clos:funcallable-standard-object) () 24 | (:metaclass clos:funcallable-standard-class)) 25 | 26 | ;; The following code ensures that possibly incorrect lists of direct 27 | ;; superclasses are corrected. 28 | 29 | #+lispworks4 30 | (defun modify-superclasses (direct-superclasses &optional (standardp t)) 31 | (if (null direct-superclasses) 32 | (list (if standardp 33 | (find-class 'standard-object) 34 | (find-class 'funcallable-standard-object))) 35 | (let ((standard-object (if standardp 36 | (find-class 'standard-object) 37 | (find-class 'clos:funcallable-standard-object)))) 38 | (if (eq (car (last direct-superclasses)) standard-object) 39 | (if standardp 40 | direct-superclasses 41 | (append (butlast direct-superclasses) 42 | (list (find-class 'funcallable-standard-object)))) 43 | (remove standard-object direct-superclasses))))) 44 | 45 | ;; During class re/initialization, we take care of the following things: 46 | ;; - Optimization of slot accessors is deactivated. 47 | ;; - Lists of direct superclasses are corrected. 48 | ;; - Removal of direct subclasses. 49 | 50 | (defun optimize-slot-access-p (class) 51 | (flet ((applicablep (specializer) 52 | (if (consp specializer) 53 | (eql class (eql-specializer-object specializer)) 54 | (subclassp (class-of class) specializer)))) 55 | (and (loop for method in (generic-function-methods #'slot-value-using-class) 56 | never (applicablep (first (method-specializers method)))) 57 | (loop for method in (generic-function-methods #'(setf slot-value-using-class)) 58 | never (applicablep (second (method-specializers method))))))) 59 | 60 | (cl:defmethod initialize-instance :around 61 | ((class standard-class) &rest initargs 62 | #+lispworks4 &key 63 | #+lispworks4 (direct-superclasses ())) 64 | (apply #'call-next-method class 65 | #+lispworks4 :direct-superclasses 66 | #+lispworks4 (modify-superclasses direct-superclasses) 67 | :optimize-slot-access (optimize-slot-access-p class) 68 | initargs)) 69 | 70 | (cl:defmethod reinitialize-instance :around 71 | ((class standard-class) &rest initargs 72 | #+lispworks4 &key 73 | #+lispworks4 (direct-superclasses () direct-superclasses-p)) 74 | #+lispworks4 75 | (progn 76 | (when direct-superclasses-p 77 | (setq direct-superclasses (modify-superclasses direct-superclasses)) 78 | (loop for superclass in (copy-list (class-direct-superclasses class)) 79 | unless (member superclass direct-superclasses) 80 | do (remove-direct-subclass superclass class))) 81 | (if direct-superclasses-p 82 | (apply #'call-next-method class 83 | :direct-superclasses direct-superclasses 84 | :optimize-slot-access (optimize-slot-access-p class) 85 | initargs) 86 | (apply #'call-next-method class 87 | :optimize-slot-access (optimize-slot-access-p class) 88 | initargs))) 89 | #-lispworks4 90 | (apply #'call-next-method class 91 | :optimize-slot-access (optimize-slot-access-p class) 92 | initargs)) 93 | 94 | (cl:defmethod initialize-instance :around 95 | ((class funcallable-standard-class) &rest initargs 96 | #+lispworks4 &key 97 | #+lispworks4 (direct-superclasses ())) 98 | (apply #'call-next-method class 99 | #+lispworks4 :direct-superclasses 100 | #+lispworks4 (modify-superclasses direct-superclasses nil) 101 | :optimize-slot-access (optimize-slot-access-p class) 102 | initargs)) 103 | 104 | (cl:defmethod reinitialize-instance :around 105 | ((class funcallable-standard-class) &rest initargs 106 | #+lispworks4 &key 107 | #+lispworks4 (direct-superclasses () direct-superclasses-p)) 108 | #+lispworks4 109 | (progn 110 | (when direct-superclasses-p 111 | (setq direct-superclasses (modify-superclasses direct-superclasses nil)) 112 | (loop for superclass in (copy-list (class-direct-superclasses class)) 113 | unless (member superclass direct-superclasses) 114 | do (remove-direct-subclass superclass class))) 115 | (if direct-superclasses-p 116 | (apply #'call-next-method class 117 | :direct-superclasses direct-superclasses 118 | :optimize-slot-access (optimize-slot-access-p class) 119 | initargs) 120 | (apply #'call-next-method class 121 | :optimize-slot-access (optimize-slot-access-p class) 122 | initargs))) 123 | #-lispworks4 124 | (apply #'call-next-method class 125 | :optimize-slot-access (optimize-slot-access-p class) 126 | initargs)) 127 | 128 | ;; The following is necessary for forward-referenced-classes. 129 | ;; Since we replace the original funcallable-standard-object with 130 | ;; a new one, we have to prevent LispWorks from trying to use 131 | ;; the original one when forward-ferenced-classes are resolved. 132 | 133 | #+lispworks4 134 | (cl:defmethod change-class :around 135 | ((class forward-referenced-class) 136 | (new-class funcallable-standard-class) 137 | &rest initargs 138 | &key (direct-superclasses ())) 139 | (apply #'call-next-method class new-class 140 | :optimize-slot-access (optimize-slot-access-p new-class) 141 | :direct-superclasses (modify-superclasses direct-superclasses nil) 142 | initargs)) 143 | 144 | ;;; In LispWorks, the slot accessors (slot-value-using-class, etc.) are specialized 145 | ;;; on slot names instead of effective slot definitions. In order to fix this, 146 | ;;; we need to rewire the slot access protocol. 147 | 148 | (declaim (inline find-slot)) 149 | 150 | (defun find-slot (slot-name class) 151 | (declare (optimize (speed 3) (debug 0) (safety 0) 152 | (compilation-speed 0))) 153 | (loop for slot in (class-slots class) 154 | when (eq slot-name (slot-definition-name slot)) 155 | return slot)) 156 | 157 | (cl:defmethod slot-value-using-class 158 | ((class standard-class) object (slot symbol)) 159 | (declare (optimize (speed 3) (debug 0) (safety 0) 160 | (compilation-speed 0))) 161 | (let ((slotd (find-slot slot class))) 162 | (if slotd 163 | (slot-value-using-class class object slotd) 164 | (slot-missing class object slot 'slot-value)))) 165 | 166 | (cl:defmethod slot-value-using-class 167 | ((class standard-class) object (slotd standard-effective-slot-definition)) 168 | (declare (optimize (speed 3) (debug 0) (safety 0) 169 | (compilation-speed 0))) 170 | (slot-value-using-class 171 | (load-time-value (class-prototype (find-class 'cl:standard-class))) 172 | object 173 | (slot-definition-name slotd))) 174 | 175 | (cl:defmethod (setf slot-value-using-class) 176 | (new-value (class standard-class) object (slot symbol)) 177 | (declare (optimize (speed 3) (debug 0) (safety 0) 178 | (compilation-speed 0))) 179 | (let ((slotd (find-slot slot class))) 180 | (if slotd 181 | (setf (slot-value-using-class class object slotd) 182 | new-value) 183 | (slot-missing class object slot 'setf new-value)))) 184 | 185 | (cl:defmethod (setf slot-value-using-class) 186 | (new-value (class standard-class) object (slotd standard-effective-slot-definition)) 187 | (declare (optimize (speed 3) (debug 0) (safety 0) 188 | (compilation-speed 0))) 189 | (setf (slot-value-using-class 190 | (load-time-value (class-prototype (find-class 'cl:standard-class))) 191 | object 192 | (slot-definition-name slotd)) 193 | new-value)) 194 | 195 | (cl:defmethod slot-boundp-using-class 196 | ((class standard-class) object (slot symbol)) 197 | (declare (optimize (speed 3) (debug 0) (safety 0) 198 | (compilation-speed 0))) 199 | (let ((slotd (find-slot slot class))) 200 | (if slotd 201 | (slot-boundp-using-class class object slotd) 202 | (slot-missing class object slot 'slot-boundp)))) 203 | 204 | (cl:defmethod slot-boundp-using-class 205 | ((class standard-class) object (slotd standard-effective-slot-definition)) 206 | (declare (optimize (speed 3) (debug 0) (safety 0) 207 | (compilation-speed 0))) 208 | (slot-boundp-using-class 209 | (load-time-value (class-prototype (find-class 'cl:standard-class))) 210 | object 211 | (slot-definition-name slotd))) 212 | 213 | (cl:defmethod slot-makunbound-using-class 214 | ((class standard-class) object (slot symbol)) 215 | (declare (optimize (speed 3) (debug 0) (safety 0) 216 | (compilation-speed 0))) 217 | (let ((slotd (find-slot slot class))) 218 | (if slotd 219 | (slot-makunbound-using-class class object slotd) 220 | (slot-missing class object slot 'slot-makunbound)))) 221 | 222 | (cl:defmethod slot-makunbound-using-class 223 | ((class standard-class) object (slotd standard-effective-slot-definition)) 224 | (declare (optimize (speed 3) (debug 0) (safety 0) 225 | (compilation-speed 0))) 226 | (slot-makunbound-using-class 227 | (load-time-value (class-prototype (find-class 'cl:standard-class))) 228 | object 229 | (slot-definition-name slotd))) 230 | 231 | ;; In LispWorks, eql specializers are lists. We cannot change this 232 | ;; but we can soften some of the incompatibilities. 233 | 234 | (deftype eql-specializer () 235 | '(or eql-specializer* 236 | (satisfies clos:eql-specializer-p))) 237 | 238 | (cl:defgeneric eql-specializer-object (eql-specializer) 239 | (:method ((cons cons)) 240 | (if (clos:eql-specializer-p cons) 241 | (cadr cons) 242 | (error "~S is not an eql-specializer." cons)))) 243 | 244 | (defun intern-eql-specializer (object) 245 | `(eql ,object)) 246 | 247 | (defclass eql-specializer* (metaobject) 248 | ((obj :reader eql-specializer-object 249 | :initarg eso 250 | :initform (error "Use intern-eql-specializer to create eql-specializers.")) 251 | (direct-methods :reader specializer-direct-methods 252 | :accessor es-direct-methods 253 | :initform ()))) 254 | 255 | (defvar *eql-specializers* (make-hash-table :weak-kind :value)) 256 | 257 | #+lispworks5.0 258 | (defvar *eql-specializers-lock* (mp:make-lock)) 259 | 260 | #-lispworks5.0 261 | (defun intern-eql-specializer* (object) 262 | (or (gethash object *eql-specializers*) 263 | (with-hash-table-locked *eql-specializers* 264 | (or (gethash object *eql-specializers*) 265 | (setf (gethash object *eql-specializers*) 266 | (make-instance 'eql-specializer* 'eso object)))))) 267 | 268 | #+lispworks5.0 269 | (defun intern-eql-specializer* (object) 270 | (or (gethash object *eql-specializers*) 271 | (mp:with-lock (*eql-specializers-lock*) 272 | (or (gethash object *eql-specializers*) 273 | (setf (gethash object *eql-specializers*) 274 | (make-instance 'eql-specializer* 'eso object)))))) 275 | 276 | (cl:defmethod add-direct-method ((specializer eql-specializer*) (method method)) 277 | (pushnew method (es-direct-methods specializer))) 278 | 279 | (cl:defmethod remove-direct-method ((specializer eql-specializer*) (method method)) 280 | (removef (es-direct-methods specializer) method)) 281 | 282 | (cl:defgeneric specializer-direct-generic-functions (specializer) 283 | (:method ((class class)) 284 | (remove-duplicates 285 | (mapcar #'method-generic-function 286 | (specializer-direct-methods class)))) 287 | (:method ((eql-specializer eql-specializer*)) 288 | (remove-duplicates 289 | (mapcar #'method-generic-function 290 | (specializer-direct-methods eql-specializer)))) 291 | (:method ((cons cons)) 292 | (specializer-direct-generic-functions 293 | (intern-eql-specializer* 294 | (eql-specializer-object cons))))) 295 | 296 | ;; The following method ensures that remove-method is called. 297 | 298 | #+lispworks4 299 | (cl:defmethod add-method :before ((gf standard-generic-function) (method method)) 300 | (when-let (old-method (find-method gf (method-qualifiers method) 301 | (method-specializers method) nil)) 302 | (remove-method gf old-method))) 303 | 304 | ;; The following two methods ensure that add/remove-direct-method is called, 305 | ;; and that the dependent protocol for generic function works. 306 | 307 | (cl:defmethod add-method :after ((gf standard-generic-function) (method method)) 308 | (dolist (specializer (method-specializers method)) 309 | (if (consp specializer) 310 | (add-direct-method (intern-eql-specializer* 311 | (eql-specializer-object specializer)) 312 | method) 313 | #+lispworks4 314 | (add-direct-method specializer method))) 315 | #+lispworks4.3 316 | (map-dependents gf (lambda (dep) (update-dependent gf dep 'add-method method)))) 317 | 318 | (cl:defmethod remove-method :after ((gf standard-generic-function) (method method)) 319 | (dolist (specializer (method-specializers method)) 320 | (if (consp specializer) 321 | (remove-direct-method (intern-eql-specializer* 322 | (eql-specializer-object specializer)) 323 | method) 324 | #+lispworks4 325 | (remove-direct-method specializer method))) 326 | #+lispworks4.3 327 | (map-dependents gf (lambda (dep) (update-dependent gf dep 'remove-method method)))) 328 | 329 | (cl:defgeneric find-method-combination (gf combi combi-options) 330 | (:method ((gf generic-function) (combi symbol) combi-options) 331 | (when combi-options 332 | (error "This implementation of find-method-combination cannot handle method combination options.")) 333 | (clos::find-a-method-combination-type combi))) 334 | 335 | ;; "Native" make-method-lambda. 336 | 337 | (cl:defmethod make-method-lambda ((gf generic-function) (method standard-method) lambda-expression environment) 338 | (destructuring-bind 339 | (lambda (&rest args) &body body) 340 | lambda-expression 341 | (declare (ignore lambda)) 342 | (loop with documentation = :unbound 343 | for (car . cdr) = body then cdr 344 | while (or (and cdr (stringp car)) 345 | (and (consp car) (eq (car car) 'declare))) 346 | if (stringp car) 347 | do (setf documentation 348 | (if (eq documentation :unbound) car 349 | (warn "Too many documentation strings in lambda expression ~S." 350 | lambda-expression))) 351 | else append (loop for declaration in (cdr car) 352 | if (eq (car declaration) 'ignore) 353 | collect `(ignorable ,@(cdr declaration)) 354 | and collect `(dynamic-extent ,@(cdr declaration)) 355 | else collect declaration) into declarations 356 | finally (multiple-value-bind 357 | (method-lambda method-args) 358 | (clos:make-method-lambda 359 | gf method args declarations 360 | `(progn ,car ,@cdr) 361 | environment) 362 | (if (eq documentation :unbound) 363 | (return (values method-lambda method-args)) 364 | (return (values 365 | `(lambda ,(cadr method-lambda) 366 | ,documentation 367 | ,@(cddr method-lambda)) 368 | method-args))))))) 369 | 370 | ;; Provide standard-instance-access and funcallable-standard-instance-access 371 | 372 | (declaim (inline standard-instance-access (setf standard-instance-access))) 373 | 374 | (defun standard-instance-access (instance location) 375 | (clos::fast-standard-instance-access instance location)) 376 | 377 | (defun (setf standard-instance-access) (new-value instance location) 378 | (setf (clos::fast-standard-instance-access instance location) new-value)) 379 | 380 | (declaim (inline funcallable-instance-access)) 381 | 382 | (defun funcallable-instance-access (instance location &rest args) 383 | (let* ((class (class-of instance)) 384 | (slot (find location (class-slots class) 385 | :key #'slot-definition-location))) 386 | (if slot 387 | (apply #'clos::funcallable-instance-access instance (slot-definition-name slot) args) 388 | (error "There is no slot with location ~S for instance ~S." location instance)))) 389 | 390 | (defun funcallable-standard-instance-access (instance location) 391 | (funcallable-instance-access instance location)) 392 | 393 | (defun (setf funcallable-standard-instance-access) (new-value instance location) 394 | (funcallable-instance-access instance location new-value)) 395 | 396 | (eval-when (:compile-toplevel :load-toplevel :execute) 397 | (pushnew :closer-mop *features*)) 398 | -------------------------------------------------------------------------------- /features.txt: -------------------------------------------------------------------------------- 1 | Features that don't adhere to AMOP in various CLOS MOP implementations, and whether and how they are resolved in Closer to MOP. 2 | 3 | Allegro Common Lisp 8.2 & 9.0 4 | 5 | - CLASS-DIRECT-DEFAULT-INITARGS and CLASS-DEFAULT-INITARGS don't return canonicalized default initargs as specified. Not fixed. 6 | - FUNCALLABLE-STANDARD-OBJECT is not used as the default superclass for classes with :metaclass FUNCALLABLE-STANDARD-CLASS. 7 | - DEFGENERIC does not call FIND-METHOD-COMBINATION. Not fixed. 8 | - DEFMETHOD doesn't call MAKE-METHOD-LAMBDA. Fixed. 9 | - The dependent protocol for generic functions doesn't work fully. Fixed. 10 | - GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER doesn't return only the required arguments. Fixed. 11 | - The function invocation protocol doesn't call COMPUTE-APPLICABLE-METHODS, COMPUTE-APPLICABLE-METHODS-USING-CLASSES and COMPUTE-EFFECTIVE-METHOD. Fixed. 12 | - The :ALLOCATION type cannot be extended. Fixed. 13 | - MAKE-METHOD-LAMBDA is not provided. Fixed. 14 | - Method functions don't take parameters as specified in AMOP, but instead just the parameters that the generic function receives. Fixed. 15 | - REINITIALIZE-INSTANCE doesn't determine a new discriminating function. Fixed. 16 | - (SETF CLASS-NAME) and (SETF GENERIC-FUNCTION-NAME) do not use REINITIALIZE-INSTANCE for changing the names. Not fixed. 17 | - SLOT-MAKUNBOUND-USING-CLASS is not specialized on slot definition metaobjects, but on symbols. Fixed. 18 | - STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are not compatible. Not fixed. 19 | - VALIDATE-SUPERCLASS doesn't recognize T as a valid superclass. Not fixed. 20 | - Subclasses of BUILT-IN-CLASS, FORWARD-REFERENCED-CLASS, FUNCALLABLE-STANDARD-CLASS, METHOD-COMBINATION, STANDARD-ACCESSOR-METHOD, STANDARD-CLASS, STANDARD-DIRECT-SLOT-DEFINITION, STANDARD-EFFECTIVE-SLOT-DEFINITION, STANDARD-GENERIC-FUNCTION, STANDARD-METHOD, STANDARD-READER-METHOD, STANDARD-SLOT-DEFINITION and STANDARD-WRITER-METHOD will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed. 21 | 22 | Allegro Common Lisp 10.0 & 10.1 23 | 24 | - CLASS-DIRECT-DEFAULT-INITARGS and CLASS-DEFAULT-INITARGS don't return canonicalized default initargs as specified. Not fixed. 25 | - DEFGENERIC does not call FIND-METHOD-COMBINATION. Not fixed. 26 | - DEFMETHOD doesn't call MAKE-METHOD-LAMBDA. Fixed. 27 | - The dependent protocol for generic functions doesn't work fully. Fixed. 28 | - GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER doesn't return only the required arguments. Fixed. 29 | - The function invocation protocol doesn't call COMPUTE-APPLICABLE-METHODS, COMPUTE-APPLICABLE-METHODS-USING-CLASSES and COMPUTE-EFFECTIVE-METHOD. Fixed. 30 | - The :ALLOCATION type cannot be extended. Fixed. 31 | - MAKE-METHOD-LAMBDA is not provided. Fixed. 32 | - Method functions don't take parameters as specified in AMOP, but instead just the parameters that the generic function receives. Fixed. 33 | - REINITIALIZE-INSTANCE doesn't determine a new discriminating function. Fixed. 34 | - (SETF CLASS-NAME) and (SETF GENERIC-FUNCTION-NAME) do not use REINITIALIZE-INSTANCE for changing the names. Not fixed. 35 | - SLOT-MAKUNBOUND-USING-CLASS is not specialized on slot definition metaobjects, but on symbols. Fixed. 36 | - VALIDATE-SUPERCLASS doesn't recognize T as a valid superclass. Not fixed. 37 | - Subclasses of BUILT-IN-CLASS, FORWARD-REFERENCED-CLASS, FUNCALLABLE-STANDARD-CLASS, METHOD-COMBINATION, STANDARD-ACCESSOR-METHOD, STANDARD-CLASS, STANDARD-DIRECT-SLOT-DEFINITION, STANDARD-EFFECTIVE-SLOT-DEFINITION, STANDARD-GENERIC-FUNCTION, STANDARD-METHOD, STANDARD-READER-METHOD, STANDARD-SLOT-DEFINITION and STANDARD-WRITER-METHOD will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed. 38 | 39 | Armed Bear Common Lisp 1.7.1 40 | 41 | All features implemented. (However, there are currently still some glitches that are not reported by MOP Feature Tests.) 42 | 43 | CLisp 2.49 44 | 45 | - Methods are not initialized with :function. Not fixed. 46 | - ADD-METHOD, REMOVE-METHOD, INITIALIZE-INSTANCE and REINITIALIZE-INSTANCE do not determine a new discriminating function. This is postponed until function invocation instead, so shouldn't be a problem in practice. 47 | - The slot order requested by a primary method for COMPUTE-SLOTS is not honoured by this MOP. Not fixed. 48 | - DEFMETHOD does not call MAKE-METHOD-LAMBDA. Fixed. 49 | - A FORWARD-REFERENCED-CLASS is not changed via CHANGE-CLASS (but is correctly reinitialized via REINITIALIZE-INSTANCE). 50 | - MAKE-METHOD-LAMBDA is not provided. Fixed. 51 | - Subclasses of METHOD-COMBINATION will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed. 52 | 53 | Clozure Common Lisp 1.11.5 54 | 55 | - ADD-METHOD, REMOVE-METHOD, INITIALIZE-INSTANCE and REINITIALIZE-INSTANCE don't call COMPUTE-DISCRIMINATING-FUNCTION. Fixed. 56 | - DEFMETHOD doesn't call GENERIC-FUNCTION-METHOD-CLASS or MAKE-METHOD-LAMBDA. Fixed. 57 | - Discriminating functions cannot be determined, and thus cannot be closures and cannot be funcalled. Fixed. 58 | - Geveric function invocation doesn't call COMPUTE-APPLICABLE-METHODS, COMPUTE-APPLICABLE-METHODS-USING-CLASSES, or COMPUTE-EFFECTIVE-METHOD. Fixed. 59 | - Generic functions cannot be empty when called. Fixed. 60 | - MAKE-METHOD-LAMBDA is not supported. Fixed. 61 | - Reinitialization of a lambda list doesn't update the argument precedence order. Fixed. 62 | - The slot order requested by a primary method for COMPUTE-SLOTS is not honoured by this MOP. Not fixed. 63 | - DOCUMENTATION doesn't return the documentation strings for slot definition metaobjects. Fixed. 64 | - REINITIALIZE-INSTANCE of a class metaobject doesn't invoke FINALIZE-INHERITANCE again. Fixed. 65 | - Subclasses of DIRECT-SLOT-DEFINITION, EFFECTIVE-SLOT-DEFINITION, GENERIC-FUNCTION, SLOT-DEFINITION, STANDARD-ACCESSOR-METHOD, STANDARD-DIRECT-SLOT-DEFINITION, STANDARD-EFFECTIVE-SLOT-DEFINITION, STANDARD-GENERIC-FUNCTION, STANDARD-METHOD, STANDARD-READER-METHOD, STANDARD-SLOT-DEFINITION and STANDARD-WRITER-METHOD will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed. 66 | 67 | CMUCL 21d 68 | 69 | - CLASS-DIRECT-DEFAULT-INITARGS and CLASS-DEFAULT-INITARGS don't return canonicalized default initargs as specified. Not fixed. 70 | - Accessor methods are not initialized with :function, :lambda-list, :slot-definition and :specializers. Fixed. 71 | - Classes cannot be anonymous. Fixed. 72 | - Class initialization doesn't call READER-METHOD-CLASS and WRITER-METHOD-CLASS for accessor methods. Fixed. 73 | - The object returned by compute-discriminating-function cannot be a closure. Likewise, the second parameter to set-funcallable-instance-function cannot be a closure, but only a "pure" function/thunk. Not fixed. 74 | - Effective slot definitions are not initialized with :documentation, and EFFECTIVE-SLOT-DEFINITION-CLASS also doesn't receive that initarg. Not fixed. 75 | - The :ALLOCATION type cannot be extended. Not fixed. 76 | - Calling DOCUMENTATION on effective slot definition metaobjects don't return their documentation as specified in ANSI Common Lisp. Fixed. 77 | - Methods are not initialized with :function. Not fixed. 78 | - Multiple slot options are not passed as lists to DIRECT-SLOT-DEFINITION-CLASS. Not fixed, but use FIX-SLOT-INITARGS as a workaround. 79 | - REINITIALIZE-INSTANCE doesn't determine a new discriminating function. Fixed. 80 | - REINITIALIZE-INSTANCE of a class metaobject doesn't invoke FINALIZE-INHERITANCE again. Not fixed. 81 | - (SETF CLASS-NAME) and (SETF GENERIC-FUNCTION-NAME) do not use REINITIALIZE-INSTANCE for changing the names. Fixed. 82 | - STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are not compatible. Not fixed. 83 | - Subclasses of BUILT-IN-CLASS, CLASS, DIRECT-SLOT-DEFINITION, EFFECTIVE-SLOT-DEFINITION, EQL-SPECIALIZER, FORWARD-REFERENCED-CLASS, FUNCALLABLE-STANDARD-CLASS, SLOT-DEFINITION, SPECIALIZER, STANDARD-ACCESSOR-METHOD, STANDARD-CLASS, STANDARD-DIRECT-SLOT-DEFINITION, STANDARD-EFFECTIVE-SLOT-DEFINITION, STANDARD-GENERIC-FUNCTION, STANDARD-METHOD, STANDARD-READER-METHOD, STANDARD-SLOT-DEFINITION and STANDARD-WRITER-METHOD will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed. 84 | 85 | Embeddable Common Lisp 16.1.3 86 | 87 | - Class initialization doesn't call READER-METHOD-CLASS and WRITER-METHOD-CLASS for accessor methods. However, ECL merely delays invocation of those two functions until a class is finalized, so this shouldn't be a problem in practice. 88 | - Subclasses of BUILT-IN-CLASS, CLASS, DIRECT-SLOT-DEFINITION, EFFECTIVE-SLOT-DEFINITION, FORWARD-REFERENCED-CLASS, FUNCALLABLE-STANDARD-CLASS, SLOT-DEFINITION, STANDARD-ACCESSOR-METHOD, STANDARD-CLASS, STANDARD-DIRECT-SLOT-DEFINITION, STANDARD-EFFECTIVE-SLOT-DEFINITION, STANDARD-GENERIC-FUNCTION, STANDARD-METHOD, STANDARD-READER-METHOD, STANDARD-SLOT-DEFINITION, and STANDARD-WRITER-METHOD will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed. 89 | 90 | LispWorks 5.1.2 Personal & Professional Edition 91 | 92 | - CLASS-DIRECT-DEFAULT-INITARGS and CLASS-DEFAULT-INITARGS don't return canonicalized default initargs as specified. Not fixed. 93 | - ADD-METHOD, REMOVE-METHOD, INITIALIZE-INSTANCE and REINITIALIZE-INSTANCE do not determine a new discriminating function. This is postponed until function invocation instead, so shouldn't be a problem in practice. 94 | - COMPUTE-APPLICABLE-METHODS-USING-CLASSES doesn't exist. Fixed. 95 | - COMPUTE-DEFAULT-INITARGS doesn't exist. Not fixed. 96 | - DEFGENERIC does not call FIND-METHOD-COMBINATION. Not fixed. 97 | - EQL-SPECIALIZER, EQL-SPECIALIZER-OBJECT and INTERN-EQL-SPECIALIZER don't exist. In LispWorks, eql specializers are lists not objects. I have provided EQL-SPECIALIZER as a type (not as a class) and EQL-SPECIALIZER-OBJECT and INTERN-EQL-SPECIALIZER to work on lists, and a class EQL-SPECIALIZER* and corresponding EQL-SPECIALIZER-OBJECT* and INTERN-EQL-SPECILAIZER* to soften the incompatibilities. 98 | - Before LispWorks 5.1, the :ALLOCATION type cannot be extended. Not fixed. 99 | - FIND-METHOD-COMBINATION doesn't exist. Fixed, but fixed version doesn't work with method combination options. 100 | - FUNCALLABLE-STANDARD-INSTANCE-ACCESS and STANDARD-INSTANCE-ACCESS don't exist. Fixed. 101 | - The function invocation protocol doesn't call COMPUTE-APPLICABLE-METHODS and COMPUTE-APPLICABLE-METHODS-USING-CLASSES. Fixed. 102 | - MAKE-METHOD-LAMBDA expects other parameters than specified. Fixed. 103 | - Method functions don't take parameters as specified in AMOP, but instead just the parameters that the generic function receives. Fixed. 104 | - The slot methods (SLOT-VALUE-USING-CLASS, etc.) are not specialized on effective slot definitions, but on slot names. Fixed. 105 | - The generated accessor methods don't use the slot methods for accessing slots. Fixed. (Don't use :optimize-slot-access to deoptimize slot access, or otherwise the fixed slot access protocol doesn't work anymore!) 106 | - SPECIALIZER doesn't exist. Not fixed. 107 | - SPECIALIZER-DIRECT-GENERIC-FUNCTIONS doesn't exist. Fixed. 108 | - STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are not compatible. Not fixed. 109 | - Subclasses of BUILT-IN-CLASS (fixed), CLASS (fixed), DIRECT-SLOT-DEFINITION, EFFECTIVE-SLOT-DEFINITION, FORWARD-REFERENCED-CLASS (fixed), FUNCALLABLE-STANDARD-CLASS (fixed), SLOT-DEFINITION, STANDARD-ACCESSOR-METHOD, STANDARD-CLASS (fixed), STANDARD-DIRECT-SLOT-DEFINITION, STANDARD-EFFECTIVE-SLOT-DEFINITION, STANDARD-GENERIC-FUNCTION, STANDARD-METHOD, STANDARD-READER-METHOD, STANDARD-SLOT-DEFINITION and STANDARD-WRITER-METHOD will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed, except where indicated otherwise. 110 | 111 | LispWorks 6.0.1 Enterprise Edition, 6.1 & 6.1.1 Professional Edition, 7.0 & 7.1.2 Hobbyist Edition 112 | 113 | - CLASS-DIRECT-DEFAULT-INITARGS and CLASS-DEFAULT-INITARGS don't return canonicalized default initargs as specified. Not fixed. 114 | - ADD-METHOD, REMOVE-METHOD, INITIALIZE-INSTANCE and REINITIALIZE-INSTANCE do not determine a new discriminating function. This is postponed until function invocation instead, so shouldn't be a problem in practice. 115 | - COMPUTE-APPLICABLE-METHODS-USING-CLASSES doesn't exist. Fixed. 116 | - DEFGENERIC does not call FIND-METHOD-COMBINATION. Not fixed. 117 | - EQL-SPECIALIZER, EQL-SPECIALIZER-OBJECT and INTERN-EQL-SPECIALIZER don't exist. In LispWorks, eql specializers are lists not objects. I have provided EQL-SPECIALIZER as a type (not as a class) and EQL-SPECIALIZER-OBJECT and INTERN-EQL-SPECIALIZER to work on lists, and a class EQL-SPECIALIZER* and corresponding EQL-SPECIALIZER-OBJECT* and INTERN-EQL-SPECILAIZER* to soften the incompatibilities. 118 | - Before LispWorks 5.1, the :ALLOCATION type cannot be extended. Not fixed. 119 | - FIND-METHOD-COMBINATION doesn't exist. Fixed, but fixed version doesn't work with method combination options. 120 | - FUNCALLABLE-STANDARD-INSTANCE-ACCESS and STANDARD-INSTANCE-ACCESS don't exist. Fixed. 121 | - The function invocation protocol doesn't call COMPUTE-APPLICABLE-METHODS and COMPUTE-APPLICABLE-METHODS-USING-CLASSES. Fixed. 122 | - MAKE-METHOD-LAMBDA expects other parameters than specified. Fixed. 123 | - Method functions don't take parameters as specified in AMOP, but instead just the parameters that the generic function receives. Fixed. 124 | - The slot methods (SLOT-VALUE-USING-CLASS, etc.) are not specialized on effective slot definitions, but on slot names. Fixed. 125 | - The generated accessor methods don't use the slot methods for accessing slots. Fixed. (Don't use :optimize-slot-access to deoptimize slot access, or otherwise the fixed slot access protocol doesn't work anymore!) 126 | - SPECIALIZER-DIRECT-GENERIC-FUNCTIONS doesn't exist. Fixed. 127 | - STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are not compatible. Not fixed. 128 | - Subclasses of BUILT-IN-CLASS (fixed), CLASS (fixed), DIRECT-SLOT-DEFINITION, EFFECTIVE-SLOT-DEFINITION, FORWARD-REFERENCED-CLASS (fixed), FUNCALLABLE-STANDARD-CLASS (fixed), SLOT-DEFINITION, STANDARD-ACCESSOR-METHOD, STANDARD-CLASS (fixed), STANDARD-DIRECT-SLOT-DEFINITION, STANDARD-EFFECTIVE-SLOT-DEFINITION, STANDARD-GENERIC-FUNCTION, STANDARD-METHOD, STANDARD-READER-METHOD, STANDARD-SLOT-DEFINITION and STANDARD-WRITER-METHOD will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed, except where indicated otherwise. 129 | 130 | MCL 5.2.1 131 | 132 | In MCL, generic functions work completely differently than specified. The specific incompatibilities are not listed and are not fixed. 133 | 134 | - The slot order requested by a primary method for COMPUTE-SLOTS is not honoured by this MOP. Not fixed. 135 | - FUNCALLABLE-STANDARD-OBJECT is not exported. Fixed. 136 | - REINITIALIZE-INSTANCE of a class metaobject doesn't invoke FINALIZE-INHERITANCE again. Not fixed. 137 | - The automatically created accessor methods in DEFCLASS forms don't call SLOT-VALUE-USING-CLASS and (SETF SLOT-VALUE-USING-CLASS). Fixed. 138 | - Subclasses of DIRECT-SLOT-DEFINITION, EFFECTIVE-SLOT-DEFINITION, SLOT-DEFINITION, STANDARD-ACCESSOR-METHOD, STANDARD-DIRECT-SLOT-DEFINITION, STANDARD-EFFECTIVE-SLOT-DEFINITION, STANDARD-GENERIC-FUNCTION, STANDARD-METHOD, STANDARD-READER-METHOD, STANDARD-SLOT-DEFINITION and STANDARD-WRITER-METHOD will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed. 139 | 140 | SBCL 2.0.10 141 | 142 | All features implemented. (In SBCL 1.0.47, there is a glitch with methods on slot-boundp-using-class, which may not work in all cases.) 143 | 144 | SCL 1.3.9 145 | 146 | - The functions ADD-DIRECT-METHOD and REMOVE-DIRECT-METHOD don't exist, and thus are also not called. Partially fixed. 147 | - CLASS-DEFAULT-INITARGS and CLASS-DIRECT-DEFAULT-INITARGS don't exist. Not fixed. 148 | - COMPUTE-EFFECTIVE-METHOD doesn't exist and isn't called. Not fixed. 149 | - MAKE-METHOD-LAMBDA doesn't exist and isn't used. Not fixed. 150 | - The dependent protocols for classes and generic functions are not implemented. Fixed. 151 | - Discriminating functions cannot be funcalled, and it's unclear whether your own discriminating functions may be closures or not. COMPUTE-DISCRIMINATING-FUNCTION exists, but requires an extra 'cache' parameter, whose purpose is not specified. Not fixed. 152 | - EQL-SPECIALIZER is not a class, but only a type. Not fixed, but the implemented behavior should be sufficient for most cases. 153 | - Allocations other than :CLASS and :INSTANCE are not supported. Not fixed. 154 | - STANDARD-INSTANCE-ACCESS and FUNCALLABLE-STANDARD-INSTANCE-ACCESS don't exist. Not fixed. 155 | - COMPUTE-APPLICABLE-METHODS is not invoked when generic functions are called. Not fixed. 156 | - Multiple slot options are not passed as lists to DIRECT-SLOT-DEFINITION-CLASS. Not fixed, but use FIX-SLOT-INITARGS as a workaround. 157 | - Reinitialization of a generic function doesn't trigger recomputing its discriminating function. Not fixed. 158 | - (SETF CLASS-NAME) and (SETF GENERIC-FUNCTION-NAME) are not implemented by way of calling REINITIALIZE-INSTANCE. Not fixed. 159 | - The class SPECIALIZER doesn't exist. Not fixed. 160 | - STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are not compatible. 161 | - Subclasses of BUILT-IN-CLASS, CLASS, FORWARD-REFERENCED-CLASS, FUNCALLABLE-STANDARD-CLASS, METHOD-COMBINATION, STANDARD-ACCESSOR-METHOD, STANDARD-CLASS, STANDARD-DIRECT-SLOT-DEFINITION, STANDARD-EFFECTIVE-SLOT-DEFINITION, STANDARD-GENERIC-FUNCTION, STANDARD-METHOD, STANDARD-READER-METHOD, STANDARD-SLOT-DEFINITION, STANDARD-WRITER-METHOD will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed. 162 | 163 | Some extra notes: 164 | 165 | - Don't rely on FIND-METHOD-COMBINATION to do its job correctly, only when you don't provide method combination options. 166 | - MAKE-METHOD-LAMBDA works in Allegro, CLisp, Clozure Common Lisp, CMUCL, LispWorks and SBCL as specified (but make sure that the respective generic function and method metaobject classes and make-method-lambda definitions are part of your compilation enviroment). 167 | - Specialize the methods for the dependent protocol on the class or generic function metaobject class. The example in AMOP doesn't do this but that is fragile code. 168 | - Don't rely on methods being initialized with the specified initargs from inside the MOP. 169 | - If you specialize DIRECT-SLOT-DEFINITION-CLASS, use FIX-SLOT-INITARGS in portable code. 170 | - AMOP specifies that :declarations is used when initializing generic functions, whereas ANSI Common Lisp specifies that 'declare is used. Since almost all MOP implementations adhere to AMOP in this regard, I have also chosen that path. 171 | -------------------------------------------------------------------------------- /features.lisp: -------------------------------------------------------------------------------- 1 | :abcl1.7.1 2 | #| all features implemented |# 3 | 4 | :allegro8.2-9.0 5 | ((:class-default-initargs) 6 | (:class-direct-default-initargs) 7 | (:default-superclass-for-funcallable-standard-class-is-funcallable-standard-object) 8 | (:defgeneric-calls-find-method-combination) 9 | (:defmethod-calls-make-method-lambda fixed) 10 | (:dependent-protocol-for-generic-functions fixed) 11 | (:extensible-allocation fixed) 12 | (:function-invocation-calls-compute-applicable-methods fixed) 13 | (:function-invocation-calls-compute-applicable-methods-using-classes fixed) 14 | (:function-invocation-calls-compute-effective-method fixed) 15 | (:generic-function-argument-precedence-order-returns-required-arguments fixed) 16 | (:make-method-lambda fixed) 17 | (:method-functions-take-processed-parameters fixed) 18 | (:method-lambdas-are-processed fixed) 19 | (:reinitialize-instance-calls-compute-discriminating-function fixed) 20 | (:setf-class-name-calls-reinitialize-instance) 21 | (:setf-generic-function-name-calls-reinitialize-instance) 22 | (:slot-makunbound-using-class-specialized-on-slot-definition fixed) 23 | (:standard-class-and-funcallable-standard-class-are-compatible) 24 | (:subclasses-of-built-in-class-do-not-inherit-exported-slots) 25 | (:subclasses-of-forward-referenced-class-do-not-inherit-exported-slots) 26 | (:subclasses-of-funcallable-standard-class-do-not-inherit-exported-slots) 27 | (:subclasses-of-method-combination-do-not-inherit-exported-slots) 28 | (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) 29 | (:subclasses-of-standard-class-do-not-inherit-exported-slots) 30 | (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) 31 | (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) 32 | (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) 33 | (:subclasses-of-standard-method-do-not-inherit-exported-slots) 34 | (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) 35 | (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) 36 | (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots) 37 | (:t-is-always-a-valid-superclass)) 38 | 39 | :allegro10.0-10.1 40 | ((:class-default-initargs) 41 | (:class-direct-default-initargs) 42 | (:defgeneric-calls-find-method-combination) 43 | (:defmethod-calls-make-method-lambda fixed) 44 | (:dependent-protocol-for-generic-functions fixed) 45 | (:extensible-allocation fixed) 46 | (:function-invocation-calls-compute-applicable-methods fixed) 47 | (:function-invocation-calls-compute-applicable-methods-using-classes fixed) 48 | (:function-invocation-calls-compute-effective-method fixed) 49 | (:generic-function-argument-precedence-order-returns-required-arguments fixed) 50 | (:make-method-lambda fixed) 51 | (:method-functions-take-processed-parameters fixed) 52 | (:method-lambdas-are-processed fixed) 53 | (:reinitialize-instance-calls-compute-discriminating-function fixed) 54 | (:setf-class-name-calls-reinitialize-instance) 55 | (:setf-generic-function-name-calls-reinitialize-instance) 56 | (:slot-makunbound-using-class-specialized-on-slot-definition fixed) 57 | (:subclasses-of-built-in-class-do-not-inherit-exported-slots) 58 | (:subclasses-of-forward-referenced-class-do-not-inherit-exported-slots) 59 | (:subclasses-of-funcallable-standard-class-do-not-inherit-exported-slots) 60 | (:subclasses-of-method-combination-do-not-inherit-exported-slots) 61 | (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) 62 | (:subclasses-of-standard-class-do-not-inherit-exported-slots) 63 | (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) 64 | (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) 65 | (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) 66 | (:subclasses-of-standard-method-do-not-inherit-exported-slots) 67 | (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) 68 | (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) 69 | (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots) 70 | (:t-is-always-a-valid-superclass)) 71 | 72 | :clisp2.49 73 | ((:accessor-method-initialized-with-function) 74 | (:add-method-calls-compute-discriminating-function) 75 | (:compute-slots-requested-slot-order-honoured) 76 | (:defmethod-calls-make-method-lambda fixed) 77 | (:forward-referenced-class-changed-by-change-class) 78 | (:initialize-instance-calls-compute-discriminating-function) 79 | (:make-method-lambda fixed) 80 | (:method-initialized-with-function) 81 | (:method-lambdas-are-processed fixed) 82 | (:reinitialize-instance-calls-compute-discriminating-function) 83 | (:remove-method-calls-compute-discriminating-function) 84 | (:subclasses-of-method-combination-do-not-inherit-exported-slots)) 85 | 86 | :clozure-common-lisp1.11.5 87 | ((:add-method-calls-compute-discriminating-function fixed) 88 | (:compute-slots-requested-slot-order-honoured) 89 | (:defmethod-calls-generic-function-method-class fixed) 90 | (:defmethod-calls-make-method-lambda fixed) 91 | (:discriminating-functions-can-be-closures fixed) 92 | (:discriminating-functions-can-be-funcalled fixed) 93 | (:function-invocation-calls-compute-applicable-methods fixed) 94 | (:function-invocation-calls-compute-applicable-methods-using-classes fixed) 95 | (:function-invocation-calls-compute-effective-method fixed) 96 | (:generic-functions-can-be-empty fixed) 97 | (:initialize-instance-calls-compute-discriminating-function fixed) 98 | (:make-method-lambda fixed) 99 | (:method-functions-take-processed-parameters fixed) 100 | (:method-lambdas-are-processed fixed) 101 | (:reinitialize-instance-calls-compute-discriminating-function fixed) 102 | (:reinitialize-instance-calls-finalize-inheritance fixed) 103 | (:reinitialize-lambda-list-reinitializes-argument-precedence-order fixed) 104 | (:remove-method-calls-compute-discriminating-function fixed) 105 | (:slot-definition-documentation fixed) 106 | (:subclasses-of-direct-slot-definition-do-not-inherit-exported-slots) 107 | (:subclasses-of-effective-slot-definition-do-not-inherit-exported-slots) 108 | (:subclasses-of-generic-function-do-not-inherit-exported-slots) 109 | (:subclasses-of-slot-definition-do-not-inherit-exported-slots) 110 | (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slot) 111 | (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) 112 | (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) 113 | (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) 114 | (:subclasses-of-standard-method-do-not-inherit-exported-slots) 115 | (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) 116 | (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) 117 | (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) 118 | (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots)) 119 | 120 | :cmu21d 121 | ((:accessor-method-initialized-with-function fixed) 122 | (:accessor-method-initialized-with-lambda-list fixed) 123 | (:accessor-method-initialized-with-slot-definition fixed) 124 | (:accessor-method-initialized-with-specializers fixed) 125 | (:anonymous-classes fixed) 126 | (:class-default-initargs) 127 | (:class-direct-default-initargs) 128 | (:class-initialization-calls-reader-method-class fixed) 129 | (:class-initialization-calls-writer-method-class fixed) 130 | (:discriminating-functions-can-be-closures) 131 | (:discriminating-functions-can-be-funcalled) 132 | (:documentation-passed-to-effective-slot-definition-class) 133 | (:effective-slot-definition-initialized-with-documentation) 134 | (:extensible-allocation) 135 | (:method-initialized-with-function) 136 | (:multiple-slot-options-passed-as-list-to-direct-slot-definition-class) ; fix with fix-slot-initargs 137 | (:reinitialize-instance-calls-compute-discriminating-function fixed) 138 | (:reinitialize-instance-calls-finalize-inheritance) 139 | (:setf-class-name-calls-reinitialize-instance) 140 | (:setf-generic-function-name-calls-reinitialize-instance) 141 | (:slot-definition-documentation fixed) 142 | (:standard-class-and-funcallable-standard-class-are-compatible) 143 | (:subclasses-of-built-in-class-do-not-inherit-exported-slots) 144 | (:subclasses-of-class-do-not-inherit-exported-slots) 145 | (:subclasses-of-direct-slot-definition-do-not-inherit-exported-slots) 146 | (:subclasses-of-effective-slot-definition-do-not-inherit-exported-slots) 147 | (:subclasses-of-eql-specializer-do-not-inherit-exported-slots) 148 | (:subclasses-of-forward-referenced-class-do-not-inherit-exported-slots) 149 | (:subclasses-of-funcallable-standard-class-do-not-inherit-exported-slots) 150 | (:subclasses-of-slot-definition-do-not-inherit-exported-slots) 151 | (:subclasses-of-specializer-do-not-inherit-exported-slots) 152 | (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) 153 | (:subclasses-of-standard-class-do-not-inherit-exported-slots) 154 | (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) 155 | (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) 156 | (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) 157 | (:subclasses-of-standard-method-do-not-inherit-exported-slots) 158 | (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) 159 | (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) 160 | (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots)) 161 | 162 | :ecl16.1.3 163 | ((:class-initialization-calls-reader-method-class) 164 | (:class-initialization-calls-writer-method-class) 165 | (:subclasses-of-built-in-class-do-not-inherit-exported-slots fixed) 166 | (:subclasses-of-class-do-not-inherit-exported-slots fixed) 167 | (:subclasses-of-direct-slot-definition-do-not-inherit-exported-slots fixed) 168 | (:subclasses-of-effective-slot-definition-do-not-inherit-exported-slots fixed) 169 | (:subclasses-of-forward-referenced-class-do-not-inherit-exported-slots fixed) 170 | (:subclasses-of-funcallable-standard-class-do-not-inherit-exported-slots fixed) 171 | (:subclasses-of-slot-definition-do-not-inherit-exported-slots fixed) 172 | (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) 173 | (:subclasses-of-standard-class-do-not-inherit-exported-slots fixed) 174 | (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots fixed) 175 | (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots fixed) 176 | (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) 177 | (:subclasses-of-standard-method-do-not-inherit-exported-slots fixed) 178 | (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) 179 | (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots fixed) 180 | (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots)) 181 | 182 | :lispworks5.1-5.1.2 183 | ((:add-method-calls-compute-discriminating-function) 184 | (:add-method-updates-specializer-direct-generic-functions fixed) 185 | (:class-default-initargs) 186 | (:class-direct-default-initargs) 187 | (:compute-applicable-methods-using-classes fixed) 188 | (:compute-default-initargs) 189 | (:defgeneric-calls-find-method-combination) 190 | (:eql-specializer) ; partially fixed 191 | (:eql-specializer-object fixed) 192 | (:eql-specializers-are-objects) 193 | (:finalize-inheritance-calls-compute-default-initargs) 194 | (:find-method-combination fixed) ; partially 195 | (:funcallable-standard-instance-access fixed) 196 | (:function-invocation-calls-compute-applicable-methods fixed) 197 | (:function-invocation-calls-compute-applicable-methods-using-classes fixed) 198 | (:initialize-instance-calls-compute-discriminating-function) 199 | (:intern-eql-specializer fixed) ; partially 200 | (:make-method-lambda fixed) 201 | (:method-functions-take-processed-parameters fixed) 202 | (:reinitialize-instance-calls-compute-discriminating-function) 203 | (:remove-method-calls-compute-discriminating-function) 204 | (:setf-slot-value-using-class-specialized-on-slot-definition fixed) 205 | (:slot-boundp-using-class-specialized-on-slot-definition fixed) 206 | (:slot-makunbound-using-class-specialized-on-slot-definition fixed) 207 | (:slot-reader-calls-slot-value-using-class fixed) 208 | (:slot-value-using-class-specialized-on-slot-definition fixed) 209 | (:slot-writer-calls-slot-value-using-class fixed) 210 | (:specializer) 211 | (:specializer-direct-generic-functions fixed) 212 | (:standard-class-and-funcallable-standard-class-are-compatible) 213 | (:standard-instance-access fixed) 214 | (:subclasses-of-built-in-class-do-not-inherit-exported-slots fixed) 215 | (:subclasses-of-class-do-not-inherit-exported-slots fixed) 216 | (:subclasses-of-direct-slot-definition-do-not-inherit-exported-slots) 217 | (:subclasses-of-effective-slot-definition-do-not-inherit-exported-slots) 218 | (:subclasses-of-forward-referenced-class-do-not-inherit-exported-slots fixed) 219 | (:subclasses-of-funcallable-standard-class-do-not-inherit-exported-slots fixed) 220 | (:subclasses-of-slot-definition-do-not-inherit-exported-slots) 221 | (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) 222 | (:subclasses-of-standard-class-do-not-inherit-exported-slots fixed) 223 | (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) 224 | (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) 225 | (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) 226 | (:subclasses-of-standard-method-do-not-inherit-exported-slots) 227 | (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) 228 | (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) 229 | (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots)) 230 | 231 | :lispworks6.0.1-7.1.2 232 | ((:add-method-calls-compute-discriminating-function) 233 | (:add-method-updates-specializer-direct-generic-functions fixed) 234 | (:class-default-initargs) 235 | (:class-direct-default-initargs) 236 | (:compute-applicable-methods-using-classes fixed) 237 | (:defgeneric-calls-find-method-combination) 238 | (:eql-specializer) ; partially fixed 239 | (:eql-specializer-object fixed) 240 | (:eql-specializers-are-objects) 241 | (:find-method-combination fixed) ; partially 242 | (:funcallable-standard-instance-access fixed) 243 | (:function-invocation-calls-compute-applicable-methods fixed) 244 | (:function-invocation-calls-compute-applicable-methods-using-classes fixed) 245 | (:initialize-instance-calls-compute-discriminating-function) 246 | (:intern-eql-specializer fixed) ; partially 247 | (:make-method-lambda fixed) 248 | (:method-functions-take-processed-parameters fixed) 249 | (:reinitialize-instance-calls-compute-discriminating-function) 250 | (:remove-method-calls-compute-discriminating-function) 251 | (:setf-slot-value-using-class-specialized-on-slot-definition fixed) 252 | (:slot-boundp-using-class-specialized-on-slot-definition fixed) 253 | (:slot-makunbound-using-class-specialized-on-slot-definition fixed) 254 | (:slot-reader-calls-slot-value-using-class fixed) 255 | (:slot-value-using-class-specialized-on-slot-definition fixed) 256 | (:slot-writer-calls-slot-value-using-class fixed) 257 | (:specializer-direct-generic-functions fixed) 258 | (:standard-class-and-funcallable-standard-class-are-compatible) 259 | (:standard-instance-access fixed) 260 | (:subclasses-of-built-in-class-do-not-inherit-exported-slots fixed) 261 | (:subclasses-of-class-do-not-inherit-exported-slots fixed) 262 | (:subclasses-of-direct-slot-definition-do-not-inherit-exported-slots) 263 | (:subclasses-of-effective-slot-definition-do-not-inherit-exported-slots) 264 | (:subclasses-of-forward-referenced-class-do-not-inherit-exported-slots fixed) 265 | (:subclasses-of-funcallable-standard-class-do-not-inherit-exported-slots fixed) 266 | (:subclasses-of-slot-definition-do-not-inherit-exported-slots) 267 | (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) 268 | (:subclasses-of-standard-class-do-not-inherit-exported-slots fixed) 269 | (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) 270 | (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) 271 | (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) 272 | (:subclasses-of-standard-method-do-not-inherit-exported-slots) 273 | (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) 274 | (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) 275 | (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots)) 276 | 277 | :mcl5.2.1 278 | ((:add-method-calls-compute-discriminating-function) 279 | (:compute-applicable-methods-using-classes) 280 | (:compute-slots-requested-slot-order-honoured) 281 | (:default-superclass-for-funcallable-standard-class-is-funcallable-standard-object fixed) 282 | (:defmethod-calls-generic-function-method-class) 283 | (:defmethod-calls-make-method-lambda) 284 | (:discriminating-functions-can-be-closures) 285 | (:discriminating-functions-can-be-funcalled) 286 | (:funcallable-instance-functions-can-be-closures) 287 | (:funcallable-standard-object fixed) 288 | (:function-invocation-calls-compute-applicable-methods) 289 | (:function-invocation-calls-compute-applicable-methods-using-classes) 290 | (:function-invocation-calls-compute-effective-method) 291 | (:generic-function-declarations) 292 | (:generic-function-initialized-with-declarations) 293 | (:generic-functions-can-be-empty) 294 | (:initialize-instance-calls-compute-discriminating-function) 295 | (:make-method-lambda) 296 | (:method-functions-take-processed-parameters) 297 | (:method-lambdas-are-processed) 298 | (:reinitialize-instance-calls-compute-discriminating-function) 299 | (:reinitialize-instance-calls-finalize-inheritance) 300 | (:reinitialize-lambda-list-reinitializes-argument-precedence-order) 301 | (:remove-method-calls-compute-discriminating-function) 302 | (:set-funcallable-instance-function) 303 | (:setf-generic-function-name) 304 | (:setf-generic-function-name-calls-reinitialize-instance) 305 | (:slot-reader-calls-slot-value-using-class fixed) 306 | (:slot-writer-calls-slot-value-using-class fixed) 307 | (:subclasses-of-direct-slot-definition-do-not-inherit-exported-slots) 308 | (:subclasses-of-effective-slot-definition-do-not-inherit-exported-slots) 309 | (:subclasses-of-slot-definition-do-not-inherit-exported-slots) 310 | (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) 311 | (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) 312 | (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) 313 | (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) 314 | (:subclasses-of-standard-method-do-not-inherit-exported-slots) 315 | (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) 316 | (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) 317 | (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots)) 318 | 319 | :sbcl2.0.10 320 | #| all features implemented |# 321 | 322 | :scl1.3.9 323 | ((:add-direct-method fixed) 324 | (:add-method-calls-add-direct-method fixed) 325 | (:class-default-initargs) 326 | (:class-direct-default-initargs) 327 | (:compute-effective-method) 328 | (:compute-effective-method-is-generic) 329 | (:defmethod-calls-make-method-lambda) 330 | (:dependent-protocol-for-classes fixed) 331 | (:dependent-protocol-for-generic-functions fixed) 332 | (:discriminating-functions-can-be-funcalled) 333 | (:eql-specializer) 334 | (:extensible-allocation) 335 | (:funcallable-standard-instance-access) 336 | (:function-invocation-calls-compute-applicable-methods) 337 | (:function-invocation-calls-compute-effective-method) 338 | (:make-method-lambda) 339 | (:method-lambdas-are-processed) 340 | (:multiple-slot-options-passed-as-list-to-direct-slot-definition-class) 341 | (:reinitialize-instance-calls-compute-discriminating-function) 342 | (:remove-direct-method fixed) 343 | (:remove-method-calls-remove-direct-method fixed) 344 | (:setf-class-name-calls-reinitialize-instance) 345 | (:setf-generic-function-name-calls-reinitialize-instance) 346 | (:specializer) 347 | (:standard-class-and-funcallable-standard-class-are-compatible) 348 | (:standard-instance-access) 349 | (:subclasses-of-built-in-class-do-not-inherit-exported-slots) 350 | (:subclasses-of-class-do-not-inherit-exported-slots) 351 | (:subclasses-of-forward-referenced-class-do-not-inherit-exported-slots) 352 | (:subclasses-of-funcallable-standard-class-do-not-inherit-exported-slots) 353 | (:subclasses-of-method-combination-do-not-inherit-exported-slots) 354 | (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) 355 | (:subclasses-of-standard-class-do-not-inherit-exported-slots) 356 | (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) 357 | (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) 358 | (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) 359 | (:subclasses-of-standard-method-do-not-inherit-exported-slots) 360 | (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) 361 | (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) 362 | (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots)) 363 | -------------------------------------------------------------------------------- /closer-mop-shared.lisp: -------------------------------------------------------------------------------- 1 | (in-package :closer-mop) 2 | 3 | (defun required-args (lambda-list &optional (collector #'identity)) 4 | (loop for arg in lambda-list 5 | until (member arg lambda-list-keywords) 6 | collect (funcall collector arg))) 7 | 8 | (defun ensure-finalized (class &optional (errorp t)) 9 | (if (typep class 'class) 10 | (unless (class-finalized-p class) 11 | (finalize-inheritance class)) 12 | (when errorp (error "~S is not a class." class))) 13 | class) 14 | 15 | (defun subclassp (class superclass) 16 | (flet ((get-class (class) (etypecase class 17 | (class class) 18 | (symbol (find-class class))))) 19 | 20 | (loop with class = (get-class class) 21 | with superclass = (get-class superclass) 22 | 23 | for superclasses = (list class) 24 | then (set-difference 25 | (union (class-direct-superclasses current-class) superclasses) 26 | seen) 27 | 28 | for current-class = (first superclasses) 29 | 30 | while current-class 31 | 32 | if (eq current-class superclass) return t 33 | else collect current-class into seen 34 | 35 | finally (return nil)))) 36 | 37 | #+(or allegro clozure lispworks mcl) 38 | (progn 39 | ;; validate-superclass for metaclass classes is a little bit 40 | ;; more tricky than for class metaobject classes because 41 | ;; we don't want to make all standard-classes compatible to 42 | ;; each other. 43 | 44 | ;; Our validate-superclass may get passed a class-prototype 45 | ;; as its second argument, so don't expect its readers to 46 | ;; yield useful information. (In ANSI parlance, "the 47 | ;; consequences are undefined...") 48 | 49 | (defmacro define-validate-superclass-method (class superclass) 50 | `(cl:defmethod validate-superclass ((class ,class) (superclass ,superclass)) 51 | (or (when (eq (class-of class) (find-class ',class)) 52 | (or (eq (class-of superclass) (find-class ',superclass)) 53 | (eq (class-of superclass) (find-class ',class)))) 54 | (call-next-method) 55 | (when (eq (class-of superclass) (find-class ',superclass)) 56 | (validate-superclass class (class-prototype (find-class ',class)))))))) 57 | 58 | #+(or clisp scl mezzano) 59 | (progn 60 | (declaim (inline classp)) 61 | 62 | (define-compiler-macro classp (thing) 63 | `(typep ,thing 'class)) 64 | 65 | (defun classp (thing) 66 | (typep thing 'class))) 67 | 68 | #+(or allegro clisp clozure ecl clasp lispworks sbcl) 69 | (progn ;;; New generic functions. 70 | 71 | (defclass standard-generic-function (cl:standard-generic-function) 72 | (#+(or clozure lispworks) (argument-order :accessor argument-order) 73 | #-(or abcl sbcl) (initial-methods :initform '())) 74 | 75 | (:metaclass 76 | #-lispworks funcallable-standard-class 77 | #+lispworks clos:funcallable-standard-class) 78 | 79 | #+clozure 80 | (:default-initargs :name (copy-symbol :name) :method-class (find-class 'standard-method))) 81 | 82 | #+clozure 83 | (progn 84 | (cl:defgeneric method-function (method) 85 | (:method ((method method)) 86 | (ccl:method-function method))) 87 | 88 | (defclass standard-method (cl:standard-method) 89 | ((fn :initarg :real-function :reader method-function)))) 90 | 91 | #-(or ecl clasp) 92 | (progn 93 | (declaim (inline m-function)) 94 | 95 | (defun m-function (m) 96 | (method-function m)) 97 | 98 | (define-compiler-macro m-function (m) 99 | (handler-case (method-function m) 100 | (error () `(the function (method-function (the method ,m))))))) 101 | 102 | (defun compute-argument-order (gf nof-required-args) 103 | (loop with specialized-count = (make-array nof-required-args :initial-element 0) 104 | 105 | for method in (generic-function-methods gf) do 106 | (loop for specializer in (method-specializers method) 107 | for index from 0 108 | unless (eq specializer (find-class 't)) 109 | do (incf (svref specialized-count index))) 110 | 111 | finally 112 | 113 | (loop for arg in (generic-function-argument-precedence-order gf) 114 | for pos = (position arg (generic-function-lambda-list gf)) 115 | when (> (svref specialized-count pos) 0) 116 | collect pos into argument-order 117 | finally (return-from compute-argument-order 118 | (coerce argument-order 'simple-vector))))) 119 | 120 | (defun parse-method-body (body error-form) 121 | (loop with documentation = nil 122 | for (car . cdr) = body then cdr 123 | while (or (and cdr (stringp car)) 124 | (and (consp car) (eq (car car) 'declare))) 125 | if (stringp car) 126 | do (setq documentation 127 | (if (null documentation) car 128 | (warn "Too many documentation strings in ~S." error-form))) 129 | else append (cdr car) into declarations 130 | finally (return (values documentation declarations (cons car cdr))))) 131 | 132 | #-(or abcl sbcl) (cl:defgeneric make-method-lambda (generic-function method lambda-expression environment)) 133 | 134 | #-(or ecl clasp) 135 | (cl:defmethod make-method-lambda ((gf standard-generic-function) (method standard-method) 136 | lambda-expression environment) 137 | (declare (ignore environment) (optimize (speed 3) (space 0) (compilation-speed 0))) 138 | #+(or abcl clozure lispworks sbcl) 139 | (when (only-standard-methods gf) 140 | (return-from make-method-lambda (call-next-method))) 141 | (let ((args (copy-symbol 'args)) (next-methods (copy-symbol 'next-methods)) 142 | (more-args (copy-symbol 'more-args)) (method-function (copy-symbol 'method-function))) 143 | (destructuring-bind 144 | (lambda (&rest lambda-args) &body body) 145 | lambda-expression 146 | (declare (ignore lambda-args)) 147 | (assert (eq lambda 'lambda)) 148 | (values 149 | `(lambda (,args ,next-methods &rest ,more-args) 150 | (declare (ignorable ,args ,next-methods ,more-args)) 151 | (flet ((call-next-method (&rest args) 152 | (if ,next-methods 153 | (apply (method-function (first ,next-methods)) 154 | (if args args ,args) (rest ,next-methods) ,more-args) 155 | (apply #'no-next-method 156 | (getf ,more-args :generic-function) 157 | (getf ,more-args :method) 158 | (if args args ,args)))) 159 | (next-method-p () (not (null ,next-methods)))) 160 | (declare (inline call-next-method next-method-p) 161 | (ignorable #'call-next-method #'next-method-p)) 162 | (flet ((,method-function ,@(rest lambda-expression))) 163 | (declare (inline ,method-function)) 164 | (apply #',method-function ,args)))) 165 | (let ((documentation (parse-method-body body lambda-expression))) 166 | (nconc 167 | (when documentation 168 | (list :documentation documentation)) 169 | #+clozure '(:closer-patch t) 170 | #-clozure '())))))) 171 | 172 | #+(or clozure lispworks) 173 | (cl:defgeneric compute-applicable-methods-using-classes (generic-function classes) 174 | (:method ((gf standard-generic-function) classes) 175 | (labels ((subclass* (spec1 spec2 arg-spec) 176 | (let ((cpl (class-precedence-list arg-spec))) 177 | (declare (type list cpl)) 178 | (find spec2 (the list (cdr (member spec1 cpl :test #'eq))) :test #'eq))) 179 | (method-more-specific-p (m1 m2) 180 | (declare (type method m1 m2)) 181 | (loop for n of-type fixnum across (argument-order gf) 182 | for spec1 = (nth n (method-specializers m1)) 183 | for spec2 = (nth n (method-specializers m2)) 184 | unless (eq spec1 spec2) 185 | return (subclass* spec1 spec2 (nth n classes))))) 186 | (let ((applicable-methods 187 | (sort 188 | (loop for method of-type method in (the list (generic-function-methods gf)) 189 | when (loop for class in classes 190 | for specializer in (the list (method-specializers method)) 191 | if (typep specializer 'eql-specializer) 192 | do (when (typep (eql-specializer-object specializer) class) 193 | (return-from compute-applicable-methods-using-classes (values '() nil))) 194 | else if (not (subclassp class specializer)) return nil 195 | finally (return t)) 196 | collect method) 197 | #'method-more-specific-p))) 198 | (values applicable-methods t))))) 199 | 200 | (cl:defgeneric compute-effective-method-function (gf effective-method options)) 201 | 202 | #-(or ecl clasp) 203 | (cl:defmethod compute-effective-method-function ((gf generic-function) effective-method options) 204 | (declare (optimize (speed 3) (space 0) (compilation-speed 0))) 205 | (when #-clisp options 206 | #+clisp (or (cdr (assoc :arguments options)) 207 | (cdr (assoc :duplicates options))) 208 | (cerror "Ignore these options." 209 | "This version of compute-effective-method-function does not support method combination options: ~S" 210 | options)) 211 | (let ((all-t-specializers (required-args (generic-function-lambda-list gf) 212 | (constantly (find-class 't)))) 213 | (args (copy-symbol 'args))) 214 | (labels ((transform-effective-method (form) 215 | (if (atom form) form 216 | (case (car form) 217 | (call-method (transform-effective-method 218 | (let ((the-method (transform-effective-method (cadr form))) 219 | (method-var (copy-symbol 'method-var))) 220 | `(locally (declare (optimize (speed 3) (safety 0) (debug 0))) 221 | (let ((,method-var ,the-method)) 222 | (declare (ignorable ,method-var)) 223 | (funcall (m-function ,(if (typep the-method 'method) 224 | the-method method-var)) 225 | ,args 226 | ,@(let ((subforms 227 | (loop for subform in (the list (cddr form)) 228 | collect `',subform))) 229 | (if subforms subforms '(()))) 230 | :generic-function ,gf 231 | :method ,(if (typep the-method 'method) 232 | the-method method-var))))))) 233 | (make-method (when (cddr form) 234 | (error "Incorrect make-method form: ~S." form)) 235 | (let ((method-class (generic-function-method-class gf))) 236 | #+allegro (ensure-finalized method-class) 237 | (multiple-value-bind 238 | (method-lambda method-options) 239 | (make-method-lambda 240 | gf (class-prototype method-class) 241 | `(lambda (&rest ,args) 242 | (declare (ignorable ,args)) 243 | ,(transform-effective-method (cadr form))) nil) 244 | (apply #'make-instance 245 | method-class 246 | :qualifiers '() 247 | :specializers all-t-specializers 248 | :lambda-list (generic-function-lambda-list gf) 249 | :function (compile nil method-lambda) 250 | method-options)))) 251 | (t (mapcar #'transform-effective-method (the list form))))))) 252 | (let ((emf-lambda `(lambda (&rest ,args) 253 | (declare (ignorable ,args)) 254 | ,(transform-effective-method effective-method)))) 255 | (multiple-value-bind (function warnings failure) 256 | (compile nil emf-lambda) 257 | (declare (ignore warnings)) 258 | (assert (not failure)) 259 | function))))) 260 | 261 | #+clozure 262 | (cl:defgeneric compute-effective-method (generic-function combination methods)) 263 | 264 | #+clozure 265 | (cl:defgeneric compute-discriminating-function (generic-function)) 266 | 267 | (defun get-emf (gf args nof-required-args) 268 | (declare (optimize (speed 3) (space 0) (compilation-speed 0))) 269 | (let ((applicable-methods (compute-applicable-methods gf (subseq args 0 nof-required-args)))) 270 | (if applicable-methods 271 | (multiple-value-bind 272 | (effective-method options) 273 | (compute-effective-method 274 | gf (generic-function-method-combination gf) 275 | applicable-methods) 276 | (compute-effective-method-function gf effective-method options)) 277 | (lambda (&rest args) 278 | (apply #'no-applicable-method gf args))))) 279 | 280 | (defun get-emf-using-classes (gf args classes nof-required-args) 281 | (declare (type generic-function gf) (type list args classes) 282 | (optimize (speed 3) (space 0) (compilation-speed 0))) 283 | (multiple-value-bind 284 | (applicable-methods validp) 285 | (compute-applicable-methods-using-classes gf classes) 286 | (unless validp 287 | (setq applicable-methods 288 | (compute-applicable-methods gf (subseq args 0 nof-required-args)))) 289 | (values 290 | (if applicable-methods 291 | (multiple-value-bind 292 | (effective-method options) 293 | (compute-effective-method 294 | gf (generic-function-method-combination gf) 295 | applicable-methods) 296 | (compute-effective-method-function gf effective-method options)) 297 | (lambda (&rest args) 298 | (apply #'no-applicable-method gf args))) 299 | validp))) 300 | 301 | (defvar *standard-gfs* 302 | (list #'compute-applicable-methods #'compute-applicable-methods-using-classes 303 | #'compute-effective-method #'compute-effective-method-function 304 | #'generic-function-method-class 305 | #'make-method-lambda 306 | #+allegro #'compute-discriminating-function)) 307 | 308 | (defun only-standard-methods (gf &rest other-gfs) 309 | (declare (optimize (speed 3) (space 0) (compilation-speed 0))) 310 | (loop for other-gf in (or other-gfs *standard-gfs*) 311 | always (loop for method in (generic-function-methods other-gf) 312 | for specializer = (first (method-specializers method)) 313 | if (and (typep specializer 'class) 314 | (subclassp specializer (find-class 'standard-generic-function)) 315 | (not (eq specializer (find-class 'standard-generic-function))) 316 | (typep gf specializer)) 317 | return nil 318 | else if (and (typep specializer 'eql-specializer) 319 | (eql (eql-specializer-object specializer) gf)) 320 | return nil 321 | finally (return t)))) 322 | 323 | (defun methods-all-the-same-specializers (gf) 324 | (declare (optimize (speed 3) (space 0) (compilation-speed 0))) 325 | (loop with template = (first (generic-function-methods gf)) 326 | for method in (rest (generic-function-methods gf)) 327 | always (loop for spec1 in (method-specializers template) 328 | for spec2 in (method-specializers method) 329 | always (etypecase spec1 330 | (class (etypecase spec2 331 | (class (eq spec1 spec2)) 332 | (eql-specializer nil))) 333 | (eql-specializer 334 | (etypecase spec2 335 | (class nil) 336 | (eql-specializer 337 | (eql (eql-specializer-object spec1) 338 | (eql-specializer-object spec2))))))))) 339 | 340 | (defun compute-discriminator (gf compute-native-discriminator) 341 | (declare (optimize (speed 3) (space 0) (compilation-speed 0))) 342 | (let ((nof-required-args 343 | (length (required-args 344 | (handler-case (generic-function-lambda-list gf) 345 | (unbound-slot () 346 | (return-from compute-discriminator 347 | (funcall compute-native-discriminator))))))) 348 | discriminator) 349 | #+(or clozure lispworks) 350 | (setf (argument-order gf) 351 | (compute-argument-order gf nof-required-args)) 352 | (flet ((discriminate (emf-setter args &optional (classes (loop for arg in args 353 | repeat nof-required-args 354 | collect (class-of arg)))) 355 | (declare (type list args classes) (type function emf-setter)) 356 | (multiple-value-bind (emf validp) (get-emf-using-classes gf args classes nof-required-args) 357 | (funcall emf-setter (if validp emf (lambda (&rest args) 358 | (apply (the function (get-emf gf args nof-required-args)) args)))) 359 | (apply (the function emf) args)))) 360 | (when (only-standard-methods gf #'compute-applicable-methods #'compute-applicable-methods-using-classes) 361 | (setq discriminator 362 | (if (only-standard-methods 363 | gf #'compute-effective-method #'compute-effective-method-function #'make-method-lambda 364 | #+allegro #'compute-discriminating-function) 365 | (funcall compute-native-discriminator) 366 | (let ((argument-order 367 | #-(or clozure lispworks) (compute-argument-order gf nof-required-args) 368 | #+(or clozure lispworks) (argument-order gf))) 369 | (cond ((null (generic-function-methods gf)) 370 | (lambda (&rest args) 371 | (apply #'no-applicable-method gf args))) 372 | ((methods-all-the-same-specializers gf) 373 | (let ((specializers (method-specializers (first (generic-function-methods gf)))) 374 | (effective-method-function nil)) 375 | (declare (type list specializers)) 376 | (lambda (&rest args) 377 | (declare (optimize (speed 3) (safety 0) (debug 0) 378 | (compilation-speed 0))) 379 | (cond ((loop for arg in args 380 | for spec in specializers 381 | always (etypecase spec 382 | (class (typep arg spec)) 383 | (eql-specializer (eql arg (eql-specializer-object spec))))) 384 | (if effective-method-function 385 | (apply (the function effective-method-function) args) 386 | (discriminate (lambda (emf) (setq effective-method-function emf)) args))) 387 | (t (apply #'no-applicable-method gf args)))))) 388 | ((= (length argument-order) 1) 389 | (let ((dispatch-argument-index (svref argument-order 0)) 390 | (emfs (make-hash-table :test #'eq))) 391 | (declare (type hash-table emfs) (type fixnum dispatch-argument-index)) 392 | (lambda (&rest args) 393 | (declare (optimize (speed 3) (safety 0) (debug 0) 394 | (compilation-speed 0))) 395 | (let* ((dispatch-class (class-of (nth dispatch-argument-index args))) 396 | (effective-method-function (gethash dispatch-class emfs))) 397 | (if effective-method-function 398 | (apply (the function effective-method-function) args) 399 | (discriminate (lambda (emf) (setf (gethash dispatch-class emfs) emf)) args))))))))))) 400 | (if discriminator discriminator 401 | (let ((emfs (make-hash-table :test #'equal))) 402 | (declare (type hash-table emfs)) 403 | (lambda (&rest args) 404 | (declare (optimize (speed 3) (safety 0) (debug 0) 405 | (compilation-speed 0))) 406 | (let* ((classes (loop for arg in args 407 | repeat nof-required-args 408 | collect (class-of arg))) 409 | (effective-method-function (gethash (the list classes) emfs))) 410 | (if effective-method-function 411 | (apply (the function effective-method-function) args) 412 | (discriminate (lambda (emf) (setf (gethash (the list classes) emfs) emf)) args classes))))))))) 413 | 414 | #-(or clisp clozure lispworks (and sbcl sb-thread)) 415 | (cl:defmethod compute-discriminating-function ((gf standard-generic-function)) 416 | (if (eq (class-of gf) (find-class 'standard-generic-function)) 417 | (lambda (&rest args) 418 | (let ((discriminator (compute-discriminator gf #'call-next-method))) 419 | (set-funcallable-instance-function gf discriminator) 420 | (apply discriminator args))) 421 | (compute-discriminator gf #'call-next-method))) 422 | 423 | #+(or clisp clozure lispworks (and sbcl sb-thread)) 424 | (cl:defmethod compute-discriminating-function ((gf standard-generic-function)) 425 | (compute-discriminator gf #'call-next-method)) 426 | 427 | #-(or abcl sbcl) 428 | (progn 429 | (defun maybe-remove-initial-methods (function-name) 430 | (let ((generic-function (ignore-errors (fdefinition function-name)))) 431 | (when (and generic-function (typep generic-function 'standard-generic-function)) 432 | (dolist (method (slot-value generic-function 'initial-methods)) 433 | (remove-method generic-function method))))) 434 | 435 | #-(or allegro lispworks) 436 | (defmacro without-redefinition-warnings (&body body) 437 | `(progn ,@body)) 438 | 439 | #+allegro 440 | (defmacro without-redefinition-warnings (&body body) 441 | `(excl:without-redefinition-warnings ,@body)) 442 | 443 | #+lispworks 444 | (defmacro without-redefinition-warnings (&body body) 445 | `(let ((dspec:*redefinition-action* :quiet)) ,@body)) 446 | 447 | (defmacro defgeneric (&whole form name (&rest args) &body options &environment env) 448 | (loop initially (unless (every #'consp options) 449 | (error "Illegal options in defgeneric form ~S." form)) 450 | with generic-function-class-name = nil 451 | for option in options 452 | if (eq (car option) :generic-function-class) do 453 | (when (or (cddr option) (null (cadr option)) (not (symbolp (cadr option))) 454 | generic-function-class-name) 455 | (error "Illegal or duplicate :generic-function-class option in defgeneric form ~S." form)) 456 | (setq generic-function-class-name (cadr option)) 457 | end 458 | if (eq (car option) :method) collect option into method-options 459 | else collect option into non-method-options 460 | finally 461 | (let ((gf (copy-symbol 'gf)) 462 | (non-standard (when generic-function-class-name 463 | (let ((standard-generic-function (find-class 'standard-generic-function t env)) 464 | (this-generic-function (find-class generic-function-class-name t env))) 465 | (and (subclassp this-generic-function standard-generic-function) 466 | (not (eq this-generic-function standard-generic-function))))))) 467 | (return-from defgeneric 468 | `(progn (maybe-remove-initial-methods ',name) 469 | ,(if non-standard 470 | `(eval-when (:compile-toplevel :load-toplevel :execute) 471 | (cl:defgeneric ,name ,args ,@non-method-options)) 472 | `(progn 473 | (eval-when (:compile-toplevel) 474 | (cl:defgeneric ,name ,args ,@non-method-options)) 475 | (eval-when (:load-toplevel :execute) 476 | (without-redefinition-warnings 477 | (cl:defgeneric ,name ,args ,@options))))) 478 | (let ((,gf (fdefinition ',name))) 479 | ,(when non-standard 480 | `(setf (slot-value ,gf 'initial-methods) 481 | (list ,@(loop for method-option in method-options 482 | collect `(defmethod ,name ,@(cdr method-option)))))) 483 | ,gf))))))) 484 | 485 | #+(or abcl sbcl) 486 | (defmacro defgeneric (&whole form name (&rest args) &body options) 487 | (unless (every #'consp options) 488 | (error "Illegal generic function options in defgeneric form ~S." form)) 489 | (let ((options-without-methods (remove :method options :key #'car :test #'eq))) 490 | `(progn 491 | (eval-when (:compile-toplevel) 492 | (cl:defgeneric ,name ,args ,@options-without-methods)) 493 | (eval-when (:load-toplevel :execute) 494 | (cl:defgeneric ,name ,args ,@options))))) 495 | 496 | #-(or abcl sbcl) 497 | (progn 498 | (defun create-gf-lambda-list (method-lambda-list) 499 | (loop with stop-keywords = '#.(remove '&optional lambda-list-keywords) 500 | for arg in method-lambda-list 501 | until (member arg stop-keywords) 502 | collect arg into gf-lambda-list 503 | finally (return (let (rest) 504 | (cond ((member '&key method-lambda-list) 505 | (nconc gf-lambda-list '(&key))) 506 | ((setq rest (member '&rest method-lambda-list)) 507 | (nconc gf-lambda-list (subseq rest 0 2))) 508 | (t gf-lambda-list)))))) 509 | 510 | (defun extract-specializers (specialized-args form) 511 | (loop for specializer-name in (extract-specializer-names specialized-args) 512 | collect (typecase specializer-name 513 | (symbol `(find-class ',specializer-name)) 514 | (specializer specializer-name) 515 | (cons (cond 516 | ((> (length specializer-name) 2) 517 | (error "Invalid specializer ~S in defmethod form ~S." 518 | specializer-name form)) 519 | ((eq (car specializer-name) 'eql) 520 | `(intern-eql-specializer ,(cadr specializer-name))) 521 | (t (error "Invalid specializer ~S in defmethod form ~S." 522 | specializer-name form)))) 523 | (t (error "Invalid specializer ~S in defmethod form ~S." 524 | specializer-name form))))) 525 | 526 | (defun load-method (name gf-lambda-list type qualifiers specializers lambda-list function options) 527 | (let* ((gf (if (fboundp name) (fdefinition name) 528 | (ensure-generic-function name :lambda-list gf-lambda-list :generic-function-class type))) 529 | (method (apply #'make-instance 530 | (generic-function-method-class gf) 531 | :qualifiers qualifiers 532 | :specializers specializers 533 | :lambda-list lambda-list 534 | :function function 535 | options))) 536 | (add-method gf method) 537 | method))) 538 | 539 | (define-condition defmethod-without-generic-function (style-warning) 540 | ((name :initarg :name :reader dwg-name)) 541 | (:report (lambda (c s) (format s "No generic function present when encountering a defmethod for ~S. Assuming it will be an instance of standard-generic-function." (dwg-name c))))) 542 | 543 | (define-symbol-macro warn-on-defmethod-without-generic-function 544 | #-(or abcl sbcl) t 545 | #+(or abcl sbcl) nil) 546 | 547 | #-(or abcl sbcl) 548 | (defmacro defmethod (&whole form name &body body &environment env) 549 | (loop with generic-function = (when (fboundp name) (fdefinition name)) 550 | 551 | initially 552 | (when (macroexpand 'warn-on-defmethod-without-generic-function env) 553 | (unless generic-function 554 | (warn 'defmethod-without-generic-function :name name))) 555 | (unless (typep generic-function 'standard-generic-function) 556 | (return-from defmethod `(cl:defmethod ,@(cdr form)))) 557 | (when (only-standard-methods generic-function) 558 | (return-from defmethod `(cl:defmethod ,@(cdr form)))) 559 | 560 | for tail = body then (cdr tail) 561 | until (listp (car tail)) 562 | collect (car tail) into qualifiers 563 | finally 564 | (destructuring-bind 565 | ((&rest specialized-args) &body body) tail 566 | (multiple-value-bind 567 | (documentation declarations main-body) 568 | (parse-method-body body form) 569 | (let* ((lambda-list (extract-lambda-list specialized-args)) 570 | (gf-lambda-list (create-gf-lambda-list lambda-list)) 571 | (specializers (extract-specializers specialized-args form)) 572 | (method-class (generic-function-method-class generic-function))) 573 | #+allegro (ensure-finalized method-class) 574 | (multiple-value-bind 575 | (method-lambda method-options) 576 | (make-method-lambda generic-function (class-prototype method-class) 577 | `(lambda ,lambda-list 578 | ,@(when documentation (list documentation)) 579 | (declare ,@declarations) 580 | (declare (ignorable ,@(loop for arg in specialized-args 581 | until (member arg lambda-list-keywords) 582 | when (consp arg) collect (car arg)))) 583 | (block ,(if (consp name) (cadr name) name) ,@main-body)) 584 | env) 585 | (return-from defmethod 586 | `(load-method ',name ',gf-lambda-list ',(type-of generic-function) 587 | ',qualifiers (list ,@specializers) ',lambda-list 588 | (function ,method-lambda) ',method-options)))))))) 589 | 590 | #+(or abcl sbcl) 591 | (defmacro defmethod (&whole form name &body body &environment env) 592 | (declare (ignore body)) 593 | (let ((generic-function (when (fboundp name) (fdefinition name)))) 594 | (when (macroexpand 'warn-on-defmethod-without-generic-function env) 595 | (unless generic-function 596 | (warn 'defmethod-without-generic-function :name name))) 597 | `(cl:defmethod ,@(cdr form)))) 598 | ) 599 | 600 | #+(or allegro clisp cmu mcl scl) 601 | (defun ensure-method (gf lambda-expression 602 | &key (qualifiers ()) 603 | (lambda-list (cadr lambda-expression)) 604 | (specializers (required-args lambda-list (constantly (find-class 't))))) 605 | 606 | (let ((form `(defmethod ,(generic-function-name gf) ,@qualifiers 607 | ,(loop for specializer in specializers 608 | for (arg . rest) on lambda-list 609 | collect `(,arg ,specializer) into args 610 | finally (return (nconc args rest))) 611 | ,@(cddr lambda-expression)))) 612 | 613 | #+(or allegro clisp cmu scl) 614 | (funcall (compile nil `(lambda () ,form))) 615 | 616 | #+mcl (eval form))) 617 | 618 | #+(or abcl clozure ecl clasp lispworks sbcl) 619 | (defun ensure-method (gf lambda-expression 620 | &key (method-class (generic-function-method-class gf)) 621 | (qualifiers ()) 622 | (lambda-list (cadr lambda-expression)) 623 | (specializers (required-args lambda-list (constantly (find-class 't))))) 624 | (multiple-value-bind 625 | (method-lambda method-args) 626 | (make-method-lambda 627 | gf (class-prototype method-class) 628 | lambda-expression ()) 629 | (let ((method (apply #'make-instance 630 | method-class 631 | :qualifiers qualifiers 632 | :lambda-list lambda-list 633 | :specializers specializers 634 | :function 635 | #-ecl (compile nil method-lambda) 636 | #+ecl (coerce method-lambda 'function) 637 | method-args))) 638 | (add-method gf method) 639 | method))) 640 | 641 | ;; The following can be used in direct-slot-definition-class to get the correct initargs 642 | ;; for a slot. Use it like this: 643 | ;; 644 | ;; (defmethod direct-slot-definition-class 645 | ;; ((class my-standard-class) &rest initargs) 646 | ;; (destructuring-bind 647 | ;; (&key key-of-interest &allow-other-keys) 648 | ;; (fix-slot-initargs initargs) 649 | ;; ...)) 650 | 651 | (defvar *standard-slot-keys* 652 | '(:name :documentation 653 | :initargs :initform :initfunction 654 | :readers :writers)) 655 | 656 | #+(or cmu scl) 657 | (define-modify-macro nconcf (&rest lists) nconc) 658 | 659 | (defun fix-slot-initargs (initargs) 660 | #+(or abcl allegro clisp clozure ecl clasp lispworks mcl mezzano sbcl) 661 | initargs 662 | 663 | #+(or cmu scl) 664 | (let* ((counts (loop with counts 665 | for (key nil) on initargs by #'cddr 666 | do (incf (getf counts key 0)) 667 | finally (return counts))) 668 | (keys-to-fix (loop for (key value) on counts by #'cddr 669 | if (> value 1) collect key))) 670 | (if keys-to-fix 671 | (let ((multiple-standard-keys 672 | (intersection keys-to-fix *standard-slot-keys*))) 673 | (if multiple-standard-keys 674 | (error "Too many occurences of ~S in slot initargs ~S." 675 | multiple-standard-keys initargs) 676 | (loop with fixed-keys 677 | for (key value) on initargs by #'cddr 678 | if (member key keys-to-fix) 679 | do (nconcf (getf fixed-keys key) (list value)) 680 | else nconc (list key value) into fixed-initargs 681 | finally (return (nconc fixed-initargs fixed-keys))))) 682 | initargs))) 683 | --------------------------------------------------------------------------------