cl-closer-mop-0.6.orig/0002755000175000017500000000000011317133033015221 5ustar pvaneyndpvaneyndcl-closer-mop-0.6.orig/features.txt0000644000175000017500000004112211317133033017576 0ustar pvaneyndpvaneyndFeatures that don't adhere to AMOP in various CLOS MOP implementations, and whether and how they are resolved in Closer to MOP. Allegro Common Lisp 8.1 - CLASS-DIRECT-DEFAULT-INITARGS and CLASS-DEFAULT-INITARGS don't return canonicalized default initargs as specified. Not fixed. - COMPUTE-DEFAULT-INITARGS takes more parameters than specified. Not fixed. Conditionalize on #+allegro for your own methods instead. - FUNCALLABLE-STANDARD-OBJECT is not used as the default superclass for classes with :metaclass FUNCALLABLE-STANDARD-CLASS. - DEFGENERIC does not call FIND-METHOD-COMBINATION. Not fixed. - DEFMETHOD doesn't call MAKE-METHOD-LAMBDA. Fixed. - The dependent protocol for generic functions doesn't work fully. Fixed. - GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER doesn't return only the required arguments. Fixed. - The function invocation protocol doesn't call COMPUTE-APPLICABLE-METHODS, COMPUTE-APPLICABLE-METHODS-USING-CLASSES and COMPUTE-EFFECTIVE-METHOD. Fixed. - The :ALLOCATION type cannot be extended. Fixed. - MAKE-METHOD-LAMBDA is not provided. Fixed. - Method functions don't take parameters as specified in AMOP, but instead just the parameters that the generic function receives. Fixed. - REINITIALIZE-INSTANCE doesn't determine a new discriminating function. Fixed. - (SETF CLASS-NAME) and (SETF GENERIC-FUNCTION-NAME) do not use REINITIALIZE-INSTANCE for changing the names. Not fixed. - SLOT-MAKUNBOUND-USING-CLASS is not specialized on slot definition metaobjects, but on symbols. Fixed. - STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are not compatible. Not fixed. - VALIDATE-SUPERCLASS doesn't recognize T as a valid superclass. Not fixed. - 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. CLisp 2.48 - Methods are not initialized with :function. Not fixed. - 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. - The slot order requested by a primary method for COMPUTE-SLOTS is not honoured by this MOP. Not fixed. - DEFMETHOD does not call MAKE-METHOD-LAMBDA. Fixed. - A FORWARD-REFERENCED-CLASS is not changed via CHANGE-CLASS (but is correctly reinitialized via REINITIALIZE-INSTANCE). - MAKE-METHOD-LAMBDA is not provided. Fixed. - Subclasses of METHOD-COMBINATION will inherit slots whose names are exported symbols and/or accessible in the package common-lisp-user. Not fixed. Clozure Common Lisp 1.4 - ADD-METHOD, REMOVE-METHOD, INITIALIZE-INSTANCE and REINITIALIZE-INSTANCE don't call COMPUTE-DISCRIMINATING-FUNCTION. Fixed. - DEFMETHOD doesn't call GENERIC-FUNCTION-METHOD-CLASS or MAKE-METHOD-LAMBDA. Fixed. - Discriminating functions cannot be determined, and thus cannot be closures and cannot be funcalled. Fixed. - Geveric function invocation doesn't call COMPUTE-APPLICABLE-METHODS, COMPUTE-APPLICABLE-METHODS-USING-CLASSES, or COMPUTE-EFFECTIVE-METHOD. Fixed. - Generic functions cannot be empty when called. Fixed. - MAKE-METHOD-LAMBDA is not supported. Fixed. - Reinitialization of a lambda list doesn't update the argument precedence order. Fixed. - The slot order requested by a primary method for COMPUTE-SLOTS is not honoured by this MOP. Not fixed. - DOCUMENTATION doesn't return the documentation strings for slot definition metaobjects. Fixed. - REINITIALIZE-INSTANCE of a class metaobject doesn't invoke FINALIZE-INHERITANCE again. Fixed. - 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. CMUCL 20a - CLASS-DIRECT-DEFAULT-INITARGS and CLASS-DEFAULT-INITARGS don't return canonicalized default initargs as specified. Not fixed. - Accessor methods are not initialized with :function, :lambda-list, :slot-definition and :specializers. Fixed. - Classes cannot be anonymous. Fixed. - Class initialization doesn't call READER-METHOD-CLASS and WRITER-METHOD-CLASS for accessor methods. Fixed. - 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. - Effective slot definitions are not initialized with :documentation, and EFFECTIVE-SLOT-DEFINITION-CLASS also doesn't receive that initarg. Not fixed. - Calling DOCUMENTATION on effective slot definition metaobjects don't return their documentation as specified in ANSI Common Lisp. Fixed. - Methods are not initialized with :function. Not fixed. - Multiple slot options are not passed as lists to DIRECT-SLOT-DEFINITION-CLASS. Not fixed, but use FIX-SLOT-INITARGS as a workaround. - REINITIALIZE-INSTANCE doesn't determine a new discriminating function. Fixed. - REINITIALIZE-INSTANCE of a class metaobject doesn't invoke FINALIZE-INHERITANCE again. Not fixed. - (SETF CLASS-NAME) and (SETF GENERIC-FUNCTION-NAME) do not use REINITIALIZE-INSTANCE for changing the names. Fixed. - STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are not compatible. Not fixed. - 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. Embeddable Common Lisp 9.12.3 - The functions ADD-DIRECT-METHOD and REMOVE-DIRECT-METHOD don't exist, and thus are also not called. Fixed. - ADD-METHOD, REMOVE-METHOD, INITIALIZE-INSTANCE and REINITIALIZE-INSTANCE do not determine a new discriminating function. Fixed. - ADD-METHOD doesn't call FIND-METHOD or REMOVE-METHOD to remove potentially replaced methods, but uses some internal implementation instead. Fixed. - SPECIALIZER-DIRECT-GENERIC-FUNCTIONS and SPECIALIZER-DIRECT-METHODS don't exist, and thus are also not updated by ADD-METHOD and REMOVE-METHOD. Fixed. - 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. - Class reinitialization does not remove direct subclasses that should be removed. Fixed. - VALIDATE-SUPERCLASS doesn't exist, and thus isn't called to determine whether two classes in a direct superclass relationship have compatible metaclasses. Fixed. - COMPUTE-APPLICABLE-METHODS and COMPUTE-EFFECTIVE-METHOD are not generic functions. Fixed. - COMPUTE-APPLICABLE-METHODS-USING-CLASSES doesn't exist. Fixed. - COMPUTE-EFFECTIVE-METHOD returns a function object, not an effective method form. Not fixed. - DEFGENERIC does not call FIND-METHOD-COMBINATION. Not fixed. - DEFMETHOD doesn't call GENERIC-FUNCTION-METHOD-CLASS or MAKE-METHOD-LAMBDA. Fixed. - The dependent protocols for classes and generic functions are not implemented. Fixed. - EQL-SPECIALIZER, EQL-SPECIALIZER-OBJECT and INTERN-EQL-SPECIALIZER don't exist. In ECL, 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. - EXTRACT-LAMBDA-LIST and EXTRACT-SPECIALIZER-NAMES don't exist. Fixed. - FIND-METHOD-COMBINATION doesn't exist. This is partially fixed, but returns a cons describing the method combination, not an actual method combination metaobject. - FIND-METHOD and REMOVE-METHOD are not generic functions. Fixed. - The function invocation protocol doesn't call COMPUTE-APPLICABLE-METHODS, COMPUTE-APPLICABLE-METHODS-USING-CLASSES, and COMPUTE-EFFECTIVE-METHOD. Fixed. - GENERIC-FUNCTION-DECLARATIONS doesn't exist. Fixed. - GENERIC-FUNCTION-METHOD-CLASS is not a generic function. Fixed. - Generic functions cannot be empty when called. Fixed. - MAKE-METHOD-LAMBDA doesn't exist. Fixed, but this version returns a lambda that takes only unprocessed parameters. - The classes METAOBJECT and SPECIALIZER don't exist. Not fixed. - Method functions don't take parameters as specified in AMOP, but instead just the parameters that the generic function receives. Not fixed. - Method metaobjects are not initialized with :DOCUMENTATION. Fixed. - Multiple slot options are not passed as lists to DIRECT-SLOT-DEFINITION-CLASS. Not fixed, but use FIX-SLOT-INITARGS as a workaround. - (SETF CLASS-NAME) and (SETF GENERIC-FUNCTION-NAME) are not implemented by way of calling REINITIALIZE-INSTANCE. Not fixed. - The automatically created accessor methods in DEFCLASS forms don't call SLOT-VALUE-USING-CLASS and (SETF SLOT-VALUE-USING-CLASS). Fixed. - 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. LispWorks 5.1.2 Personal & Professional Edition - CLASS-DIRECT-DEFAULT-INITARGS and CLASS-DEFAULT-INITARGS don't return canonicalized default initargs as specified. Not fixed. - 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. - COMPUTE-APPLICABLE-METHODS-USING-CLASSES doesn't exist. Fixed. - COMPUTE-DEFAULT-INITARGS doesn't exist. Not fixed. - DEFGENERIC does not call FIND-METHOD-COMBINATION. Not fixed. - 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. - Before LispWorks 5.1, the :ALLOCATION type cannot be extended. Not fixed. - FIND-METHOD-COMBINATION doesn't exist. Fixed, but fixed version doesn't work with method combination options. - FUNCALLABLE-STANDARD-INSTANCE-ACCESS and STANDARD-INSTANCE-ACCESS don't exist. Fixed. - The function invocation protocol doesn't call COMPUTE-APPLICABLE-METHODS and COMPUTE-APPLICABLE-METHODS-USING-CLASSES. Fixed. - MAKE-METHOD-LAMBDA expects other parameters than specified. Fixed. - Method functions don't take parameters as specified in AMOP, but instead just the parameters that the generic function receives. Fixed. - The slot methods (SLOT-VALUE-USING-CLASS, etc.) are not specialized on effective slot definitions, but on slot names. Fixed. - 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!) - SPECIALIZER doesn't exist. Not fixed. - SPECIALIZER-DIRECT-GENERIC-FUNCTIONS doesn't exist. Fixed. - STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are not compatible. Not fixed. - 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. MCL 5.2.1 In MCL, generic functions work completely differently than specified. The specific incompatibilities are not listed and are not fixed. - The slot order requested by a primary method for COMPUTE-SLOTS is not honoured by this MOP. Not fixed. - FUNCALLABLE-STANDARD-OBJECT is not exported. Fixed. - REINITIALIZE-INSTANCE of a class metaobject doesn't invoke FINALIZE-INHERITANCE again. Not fixed. - The automatically created accessor methods in DEFCLASS forms don't call SLOT-VALUE-USING-CLASS and (SETF SLOT-VALUE-USING-CLASS). Fixed. - 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. SBCL 1.0.34 All features implemented. SCL 1.3.9 - The functions ADD-DIRECT-METHOD and REMOVE-DIRECT-METHOD don't exist, and thus are also not called. Partially fixed. - CLASS-DEFAULT-INITARGS and CLASS-DIRECT-DEFAULT-INITARGS don't exist. Not fixed. - COMPUTE-EFFECTIVE-METHOD doesn't exist and isn't called. Not fixed. - MAKE-METHOD-LAMBDA doesn't exist and isn't used. Not fixed. - The dependent protocols for classes and generic functions are not implemented. Fixed. - 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. - EQL-SPECIALIZER is not a class, but only a type. Not fixed, but the implemented behavior should be sufficient for most cases. - Allocations other than :CLASS and :INSTANCE are not supported. Not fixed. - STANDARD-INSTANCE-ACCESS and FUNCALLABLE-STANDARD-INSTANCE-ACCESS don't exist. Not fixed. - COMPUTE-APPLICABLE-METHODS is not invoked when generic functions are called. Not fixed. - Multiple slot options are not passed as lists to DIRECT-SLOT-DEFINITION-CLASS. Not fixed, but use FIX-SLOT-INITARGS as a workaround. - Reinitialization of a generic function doesn't trigger recomputing its discriminating function. Not fixed. - (SETF CLASS-NAME) and (SETF GENERIC-FUNCTION-NAME) are not implemented by way of calling REINITIALIZE-INSTANCE. Not fixed. - The class SPECIALIZER doesn't exist. Not fixed. - STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are not compatible. - 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. Some extra notes: - If you specialize COMPUTE-DEFAULT-INITAGS, conditionalize for the extra parameters in Allegro Common Lisp. - Don't rely on FIND-METHOD-COMBINATION to do its job correctly, only when you don't provide method combination options. - 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). - 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. - Don't rely on methods being initialized with the specified initargs from inside the MOP. - If you specialize DIRECT-SLOT-DEFINITION-CLASS, use FIX-SLOT-INITARGS in portable code. - 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. cl-closer-mop-0.6.orig/closer-mop-shared.lisp0000644000175000017500000010550011317133033021435 0ustar pvaneyndpvaneynd(in-package :closer-mop) (defun required-args (lambda-list &optional (collector #'identity)) (loop for arg in lambda-list until (member arg lambda-list-keywords) collect (funcall collector arg))) (defun ensure-finalized (class &optional (errorp t)) (if (typep class 'class) (unless (class-finalized-p class) (finalize-inheritance class)) (when errorp (error "~S is not a class." class))) class) (defun subclassp (class superclass) (flet ((get-class (class) (etypecase class (class class) (symbol (find-class class))))) (loop with class = (get-class class) with superclass = (get-class superclass) for superclasses = (list class) then (set-difference (union (class-direct-superclasses current-class) superclasses) seen) for current-class = (first superclasses) while current-class if (eq current-class superclass) return t else collect current-class into seen finally (return nil)))) #+(or allegro clozure ecl lispworks mcl) (progn ;; validate-superclass for metaclass classes is a little bit ;; more tricky than for class metaobject classes because ;; we don't want to make all standard-classes compatible to ;; each other. ;; Our validate-superclass may get passed a class-prototype ;; as its second argument, so don't expect its readers to ;; yield useful information. (In ANSI parlance, "the ;; consequences are undefined...") (defmacro define-validate-superclass-method (class superclass) `(cl:defmethod validate-superclass ((class ,class) (superclass ,superclass)) (or (when (eq (class-of class) (find-class ',class)) (or (eq (class-of superclass) (find-class ',superclass)) (eq (class-of superclass) (find-class ',class)))) (call-next-method) (when (eq (class-of superclass) (find-class ',superclass)) (validate-superclass class (class-prototype (find-class ',class)))))))) #+(or clisp scl) (progn (declaim (inline classp)) (define-compiler-macro classp (thing) `(typep ,thing 'class)) (defun classp (thing) (typep thing 'class))) #+(or allegro clisp clozure ecl lispworks sbcl) (progn ;;; New generic functions. #+ecl (cl:defgeneric specializer-direct-methods (metaobject)) #+ecl (defclass funcallable-standard-class (clos:funcallable-standard-class) ((direct-methods :initform '() :reader specializer-direct-methods))) (defclass standard-generic-function (cl:standard-generic-function) (#+(or clozure ecl lispworks) (argument-order :accessor argument-order) #-sbcl (initial-methods :initform '()) #+ecl (declarations :initarg :declarations :initform '() :reader generic-function-declarations)) (:metaclass #-lispworks funcallable-standard-class #+lispworks clos:funcallable-standard-class) #+clozure (:default-initargs :name (gensym) :method-class (find-class 'standard-method))) #+clozure (progn (cl:defgeneric method-function (method) (:method ((method method)) (ccl:method-function method))) (defclass standard-method (cl:standard-method) ((fn :initarg :real-function :reader method-function)))) #-ecl (progn (declaim (inline m-function)) (defun m-function (m) (method-function m)) (define-compiler-macro m-function (m) (handler-case (method-function m) (error () `(the function (method-function real-method-function (the method ,m))))))) (defun compute-argument-order (gf nof-required-args) (loop with specialized-count = (make-array nof-required-args :initial-element 0) for method in (generic-function-methods gf) do (loop for specializer in (method-specializers method) for index from 0 unless (eq specializer (find-class 't)) do (incf (svref specialized-count index))) finally (loop for arg in (generic-function-argument-precedence-order gf) for pos = (position arg (generic-function-lambda-list gf)) when (> (svref specialized-count pos) 0) collect pos into argument-order finally (return-from compute-argument-order (coerce argument-order 'simple-vector))))) (defun parse-method-body (body error-form) (loop with documentation = nil for (car . cdr) = body then cdr while (or (and cdr (stringp car)) (and (consp car) (eq (car car) 'declare))) if (stringp car) do (setq documentation (if (null documentation) car (warn "Too many documentation strings in ~S." error-form))) else append (cdr car) into declarations finally (return (values documentation declarations (cons car cdr))))) #-sbcl (cl:defgeneric make-method-lambda (generic-function method lambda-expression environment)) #-ecl (cl:defmethod make-method-lambda ((gf standard-generic-function) (method standard-method) lambda-expression environment) (declare (ignore environment) (optimize (speed 3) (space 0) (compilation-speed 0))) #+(or clozure lispworks sbcl) (when (only-standard-methods gf) (return-from make-method-lambda (call-next-method))) (let ((args (gensym)) (next-methods (gensym)) (more-args (gensym)) (method-function (gensym))) (destructuring-bind (lambda (&rest lambda-args) &body body) lambda-expression (declare (ignore lambda-args)) (assert (eq lambda 'lambda)) (values `(lambda (,args ,next-methods &rest ,more-args) (declare (dynamic-extent ,more-args) (ignorable ,args ,next-methods ,more-args)) (flet ((call-next-method (&rest args) (declare (dynamic-extent args)) (if ,next-methods (apply (method-function (first ,next-methods)) (if args args ,args) (rest ,next-methods) ,more-args) (apply #'no-next-method (getf ,more-args :generic-function) (getf ,more-args :method) (if args args ,args)))) (next-method-p () (not (null ,next-methods)))) (declare (inline call-next-method next-method-p) (ignorable #'call-next-method #'next-method-p)) (flet ((,method-function ,@(rest lambda-expression))) (declare (inline ,method-function)) (apply #',method-function ,args)))) (let ((documentation (parse-method-body body lambda-expression))) (nconc (when documentation (list :documentation documentation)) #+clozure '(:closer-patch t) #-clozure '())))))) #+(or clozure ecl lispworks) (cl:defgeneric compute-applicable-methods-using-classes (generic-function classes) (:method ((gf standard-generic-function) classes) (labels ((subclass* (spec1 spec2 arg-spec) (let ((cpl (class-precedence-list arg-spec))) (declare (type list cpl)) (find spec2 (the list (cdr (member spec1 cpl :test #'eq))) :test #'eq))) (method-more-specific-p (m1 m2) (declare (type method m1 m2)) (loop for n of-type fixnum across (argument-order gf) for spec1 = (nth n (method-specializers m1)) for spec2 = (nth n (method-specializers m2)) unless (eq spec1 spec2) return (subclass* spec1 spec2 (nth n classes))))) (let ((applicable-methods (sort (loop for method #-ecl of-type #-ecl method in (the list (generic-function-methods gf)) when (loop for class in classes for specializer in (the list (method-specializers method)) if (typep specializer 'eql-specializer) do (when (typep (eql-specializer-object specializer) class) (return-from compute-applicable-methods-using-classes (values '() nil))) else if (not (subclassp class specializer)) return nil finally (return t)) collect method) #'method-more-specific-p))) (values applicable-methods t))))) (cl:defgeneric compute-effective-method-function (gf effective-method options)) #-ecl (cl:defmethod compute-effective-method-function ((gf generic-function) effective-method options) (declare (optimize (speed 3) (space 0) (compilation-speed 0))) (when #-clisp options #+clisp (or (cdr (assoc :arguments options)) (cdr (assoc :duplicates options))) (cerror "Ignore these options." "This version of compute-effective-method-function does not support method combination options: ~S" options)) (let ((all-t-specializers (required-args (generic-function-lambda-list gf) (constantly (find-class 't)))) (args (gensym))) (labels ((transform-effective-method (form) (if (atom form) form (case (car form) (call-method (transform-effective-method (let ((the-method (transform-effective-method (cadr form))) (method-var (gensym))) `(locally (declare (optimize (speed 3) (safety 0) (debug 0))) (let ((,method-var ,the-method)) (declare (ignorable ,method-var)) (funcall (m-function ,(if (typep the-method 'method) the-method method-var)) ,args ,@(let ((subforms (loop for subform in (the list (cddr form)) collect `',subform))) (if subforms subforms '(()))) :generic-function ,gf :method ,(if (typep the-method 'method) the-method method-var))))))) (make-method (when (cddr form) (error "Incorrect make-method form: ~S." form)) (let ((method-class (generic-function-method-class gf))) #+allegro (ensure-finalized method-class) (multiple-value-bind (method-lambda method-options) (make-method-lambda gf (class-prototype method-class) `(lambda (&rest ,args) (declare (dynamic-extent ,args) (ignorable ,args)) ,(transform-effective-method (cadr form))) nil) (apply #'make-instance method-class :qualifiers '() :specializers all-t-specializers :lambda-list (generic-function-lambda-list gf) :function (compile nil method-lambda) method-options)))) (t (mapcar #'transform-effective-method (the list form))))))) (let ((emf-lambda `(lambda (&rest ,args) (declare (dynamic-extent ,args) (ignorable ,args)) ,(transform-effective-method effective-method)))) (multiple-value-bind (function warnings failure) (compile nil emf-lambda) (declare (ignore warnings)) (assert (not failure)) function))))) #+clozure (cl:defgeneric compute-effective-method (generic-function combination methods)) #+clozure (cl:defgeneric compute-discriminating-function (generic-function)) #+ecl (cl:defgeneric compute-effective-method (generic-function combination methods) (:method ((gf generic-function) combination methods) (clos:compute-effective-method gf combination methods))) #+ecl (cl:defgeneric compute-applicable-methods (gf arguments) (:method ((gf generic-function) arguments) (cl:compute-applicable-methods gf arguments))) (defun get-emf (gf args nof-required-args) (declare (optimize (speed 3) (space 0) (compilation-speed 0))) (let ((applicable-methods (compute-applicable-methods gf (subseq args 0 nof-required-args)))) (if applicable-methods (multiple-value-bind (effective-method options) (compute-effective-method gf (generic-function-method-combination gf) applicable-methods) (compute-effective-method-function gf effective-method options)) (lambda (&rest args) (declare (dynamic-extent args)) (apply #'no-applicable-method gf args))))) (defun get-emf-using-classes (gf args classes nof-required-args) (declare (type generic-function gf) (type list args classes) (optimize (speed 3) (space 0) (compilation-speed 0))) (multiple-value-bind (applicable-methods validp) (compute-applicable-methods-using-classes gf classes) (unless validp (setq applicable-methods (compute-applicable-methods gf (subseq args 0 nof-required-args)))) (values (if applicable-methods (multiple-value-bind (effective-method options) (compute-effective-method gf (generic-function-method-combination gf) applicable-methods) (compute-effective-method-function gf effective-method options)) (lambda (&rest args) (declare (dynamic-extent args)) (apply #'no-applicable-method gf args))) validp))) (defvar *standard-gfs* (list #'compute-applicable-methods #'compute-applicable-methods-using-classes #'compute-effective-method #'compute-effective-method-function #'make-method-lambda #+allegro #'compute-discriminating-function)) (defun only-standard-methods (gf &rest other-gfs) (declare (dynamic-extent other-gfs) (optimize (speed 3) (space 0) (compilation-speed 0))) (loop for other-gf in (or other-gfs *standard-gfs*) always (loop for method in (generic-function-methods other-gf) for specializer = (first (method-specializers method)) if (and (typep specializer 'class) (subclassp specializer (find-class 'standard-generic-function)) (not (eq specializer (find-class 'standard-generic-function))) (typep gf specializer)) return nil else if (and (typep specializer 'eql-specializer) (eql (eql-specializer-object specializer) gf)) return nil finally (return t)))) (defun methods-all-the-same-specializers (gf) (declare (optimize (speed 3) (space 0) (compilation-speed 0))) (loop with template = (first (generic-function-methods gf)) for method in (rest (generic-function-methods gf)) always (loop for spec1 in (method-specializers template) for spec2 in (method-specializers method) always (etypecase spec1 (class (etypecase spec2 (class (eq spec1 spec2)) (eql-specializer nil))) (eql-specializer (etypecase spec2 (class nil) (eql-specializer (eql (eql-specializer-object spec1) (eql-specializer-object spec2))))))))) (defun compute-discriminator (gf compute-native-discriminator) (declare (optimize (speed 3) (space 0) (compilation-speed 0))) (let ((nof-required-args (length (required-args (generic-function-lambda-list gf)))) discriminator) #+(or clozure ecl lispworks) (setf (argument-order gf) (compute-argument-order gf nof-required-args)) (flet ((discriminate (emf-setter args &optional (classes (loop for arg in args repeat nof-required-args collect (class-of arg)))) (declare (type list args classes) (type function emf-setter)) (multiple-value-bind (emf validp) (get-emf-using-classes gf args classes nof-required-args) (funcall emf-setter (if validp emf (lambda (&rest args) (declare (dynamic-extent args)) (apply (the function (get-emf gf args nof-required-args)) args)))) (apply (the function emf) args)))) (when (only-standard-methods gf #'compute-applicable-methods #'compute-applicable-methods-using-classes) (setq discriminator (if (only-standard-methods gf #'compute-effective-method #'compute-effective-method-function #'make-method-lambda #+allegro #'compute-discriminating-function) (funcall compute-native-discriminator) (let ((argument-order #-(or clozure ecl lispworks) (compute-argument-order gf nof-required-args) #+(or clozure ecl lispworks) (argument-order gf))) (cond ((null (generic-function-methods gf)) (lambda (&rest args) (declare (dynamic-extent args)) (apply #'no-applicable-method gf args))) ((methods-all-the-same-specializers gf) (let ((specializers (method-specializers (first (generic-function-methods gf)))) (effective-method-function nil)) (declare (type list specializers)) (lambda (&rest args) (declare (dynamic-extent args) (optimize (speed 3) (safety 0) (debug 0) (compilation-speed 0))) (cond ((loop for arg in args for spec in specializers always (etypecase spec (class (typep arg spec)) (eql-specializer (eql arg (eql-specializer-object spec))))) (if effective-method-function (apply (the function effective-method-function) args) (discriminate (lambda (emf) (setq effective-method-function emf)) args))) (t (apply #'no-applicable-method gf args)))))) ((= (length argument-order) 1) (let ((dispatch-argument-index (svref argument-order 0)) (emfs (make-hash-table :test #'eq))) (declare (type hash-table emfs) (type fixnum dispatch-argument-index)) (lambda (&rest args) (declare (dynamic-extent args) (optimize (speed 3) (safety 0) (debug 0) (compilation-speed 0))) (let* ((dispatch-class (class-of (nth dispatch-argument-index args))) (effective-method-function (gethash dispatch-class emfs))) (if effective-method-function (apply (the function effective-method-function) args) (discriminate (lambda (emf) (setf (gethash dispatch-class emfs) emf)) args))))))))))) (if discriminator discriminator (let ((emfs (make-hash-table :test #'equal))) (declare (type hash-table emfs)) (lambda (&rest args) (declare (dynamic-extent args) (optimize (speed 3) (safety 0) (debug 0) (compilation-speed 0))) (let* ((classes (loop for arg in args repeat nof-required-args collect (class-of arg))) (effective-method-function (gethash (the list classes) emfs))) (if effective-method-function (apply (the function effective-method-function) args) (discriminate (lambda (emf) (setf (gethash (the list classes) emfs) emf)) args classes))))))))) #-(or clisp lispworks) (cl:defmethod compute-discriminating-function ((gf standard-generic-function)) (if (eq (class-of gf) (find-class 'standard-generic-function)) (lambda (&rest args) (declare (dynamic-extent args)) (let ((discriminator (compute-discriminator gf #'call-next-method))) (set-funcallable-instance-function gf discriminator) (apply discriminator args))) (compute-discriminator gf #'call-next-method))) #+(or clisp lispworks) (cl:defmethod compute-discriminating-function ((gf standard-generic-function)) (compute-discriminator gf #'call-next-method)) #-sbcl (progn (defun maybe-remove-initial-methods (function-name) (let ((generic-function (ignore-errors (fdefinition function-name)))) (when (and generic-function (typep generic-function 'standard-generic-function)) (dolist (method (slot-value generic-function 'initial-methods)) (remove-method generic-function method))))) #-(or allegro lispworks) (defmacro without-redefinition-warnings (&body body) `(progn ,@body)) #+allegro (defmacro without-redefinition-warnings (&body body) `(excl:without-redefinition-warnings ,@body)) #+lispworks (defmacro without-redefinition-warnings (&body body) `(let ((dspec:*redefinition-action* :quiet)) ,@body)) (defmacro defgeneric (&whole form name (&rest args) &body options &environment env) (loop initially (unless (every #'consp options) (error "Illegal options in defgeneric form ~S." form)) with generic-function-class-name = nil for option in options if (eq (car option) :generic-function-class) do (when (or (cddr option) (null (cadr option)) (not (symbolp (cadr option))) generic-function-class-name) (error "Illegal or duplicate :generic-function-class option in defgeneric form ~S." form)) (setq generic-function-class-name (cadr option)) end if (eq (car option) :method) collect option into method-options else collect option into non-method-options finally (let ((gf (gensym)) (non-standard (when generic-function-class-name (let ((standard-generic-function (find-class 'standard-generic-function t env)) (this-generic-function (find-class generic-function-class-name t env))) (and (subclassp this-generic-function standard-generic-function) (not (eq this-generic-function standard-generic-function))))))) (return-from defgeneric `(progn (maybe-remove-initial-methods ',name) ,(if non-standard `(eval-when (:compile-toplevel :load-toplevel :execute) (cl:defgeneric ,name ,args ,@non-method-options)) `(progn (eval-when (:compile-toplevel) (cl:defgeneric ,name ,args ,@non-method-options)) (eval-when (:load-toplevel :execute) (without-redefinition-warnings (cl:defgeneric ,name ,args ,@options))))) (let ((,gf (fdefinition ',name))) ,(when non-standard `(setf (slot-value ,gf 'initial-methods) (list ,@(loop for method-option in method-options collect `(defmethod ,name ,@(cdr method-option)))))) ,gf))))))) #+sbcl (defmacro defgeneric (&whole form name (&rest args) &body options) (unless (every #'consp options) (error "Illegal generic function options in defgeneric form ~S." form)) (let ((options-without-methods (remove :method options :key #'car :test #'eq))) `(progn (eval-when (:compile-toplevel) (cl:defgeneric ,name ,args ,@options-without-methods)) (eval-when (:load-toplevel :execute) (cl:defgeneric ,name ,args ,@options))))) #-sbcl (progn (defun create-gf-lambda-list (method-lambda-list) (loop with stop-keywords = '#.(remove '&optional lambda-list-keywords) for arg in method-lambda-list until (member arg stop-keywords) collect arg into gf-lambda-list finally (return (let (rest) (cond ((member '&key method-lambda-list) (nconc gf-lambda-list '(&key))) ((setq rest (member '&rest method-lambda-list)) (nconc gf-lambda-list (subseq rest 0 2))) (t gf-lambda-list)))))) (defun extract-specializers (specialized-args form) (loop for specializer-name in (extract-specializer-names specialized-args) collect (typecase specializer-name (symbol `(find-class ',specializer-name)) (class specializer-name) (cons (cond ((> (length specializer-name) 2) (error "Invalid specializer ~S in defmethod form ~S." specializer-name form)) ((eq (car specializer-name) 'eql) `(intern-eql-specializer ,(cadr specializer-name))) (t (error "Invalid specializer ~S in defmethod form ~S." specializer-name form)))) (t (error "Invalid specializer ~S in defmethod form ~S." specializer-name form))))) (defun load-method (name gf-lambda-list type qualifiers specializers lambda-list function options) (let* ((gf (if (fboundp name) (fdefinition name) (ensure-generic-function name :lambda-list gf-lambda-list :generic-function-class type))) (method (apply #'make-instance (generic-function-method-class gf) :qualifiers qualifiers :specializers specializers :lambda-list lambda-list :function function options))) (add-method gf method) method))) (define-condition defmethod-without-generic-function (style-warning) ((name :initarg :name :reader dwg-name)) (: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))))) (define-symbol-macro warn-on-defmethod-without-generic-function #-sbcl t #+sbcl nil) #-sbcl (defmacro defmethod (&whole form name &body body &environment env) (loop with generic-function = (when (fboundp name) (fdefinition name)) initially (when (macroexpand 'warn-on-defmethod-without-generic-function env) (unless generic-function (warn 'defmethod-without-generic-function :name name))) (unless (typep generic-function 'standard-generic-function) (return-from defmethod `(cl:defmethod ,@(cdr form)))) #-ecl (when (only-standard-methods generic-function) (return-from defmethod `(cl:defmethod ,@(cdr form)))) for tail = body then (cdr tail) until (listp (car tail)) collect (car tail) into qualifiers finally (destructuring-bind ((&rest specialized-args) &body body) tail (multiple-value-bind (documentation declarations main-body) (parse-method-body body form) (let* ((lambda-list (extract-lambda-list specialized-args)) (gf-lambda-list (create-gf-lambda-list lambda-list)) (specializers (extract-specializers specialized-args form)) (method-class (generic-function-method-class generic-function))) #+allegro (ensure-finalized method-class) (multiple-value-bind (method-lambda method-options) (make-method-lambda generic-function (class-prototype method-class) `(lambda ,lambda-list ,@(when documentation (list documentation)) (declare ,@declarations) (declare (ignorable ,@(loop for arg in specialized-args until (member arg lambda-list-keywords) when (consp arg) collect (car arg)))) (block ,(if (consp name) (cadr name) name) ,@main-body)) env) (return-from defmethod `(load-method ',name ',gf-lambda-list ',(type-of generic-function) ',qualifiers (list ,@specializers) ',lambda-list (function ,method-lambda) ',method-options)))))))) #+sbcl (defmacro defmethod (&whole form name &body body &environment env) (declare (ignore body)) (let ((generic-function (when (fboundp name) (fdefinition name)))) (when (macroexpand 'warn-on-defmethod-without-generic-function env) (unless generic-function (warn 'defmethod-without-generic-function :name name))) `(cl:defmethod ,@(cdr form)))) ) #+(or allegro clisp cmu mcl scl) (defun ensure-method (gf lambda-expression &key (qualifiers ()) (lambda-list (cadr lambda-expression)) (specializers (required-args lambda-list (constantly (find-class 't))))) (let ((form `(defmethod ,(generic-function-name gf) ,@qualifiers ,(loop for specializer in specializers for (arg . rest) on lambda-list collect `(,arg ,specializer) into args finally (return (nconc args rest))) ,@(cddr lambda-expression)))) #+(or allegro clisp cmu scl) (funcall (compile nil `(lambda () ,form))) #+mcl (eval form))) #+(or clozure ecl lispworks sbcl) (defun ensure-method (gf lambda-expression &key (method-class (generic-function-method-class gf)) (qualifiers ()) (lambda-list (cadr lambda-expression)) (specializers (required-args lambda-list (constantly (find-class 't))))) (multiple-value-bind (method-lambda method-args) (make-method-lambda gf (class-prototype method-class) lambda-expression ()) (let ((method (apply #'make-instance method-class :qualifiers qualifiers :lambda-list lambda-list :specializers specializers :function #-ecl (compile nil method-lambda) #+ecl (coerce method-lambda 'function) method-args))) (add-method gf method) method))) ;; The following can be used in direct-slot-definition-class to get the correct initargs ;; for a slot. Use it like this: ;; ;; (defmethod direct-slot-definition-class ;; ((class my-standard-class) &rest initargs) ;; (declare (dynamic-extent initargs)) ;; (destructuring-bind ;; (&key key-of-interest &allow-other-keys) ;; (fix-slot-initargs initargs) ;; ...)) (defvar *standard-slot-keys* '(:name :documentation :initargs :initform :initfunction :readers :writers)) #+(or cmu ecl scl) (define-modify-macro nconcf (&rest lists) nconc) (defun fix-slot-initargs (initargs) #+(or allegro clisp clozure lispworks mcl sbcl) initargs #+(or cmu ecl scl) (let* ((counts (loop with counts for (key nil) on initargs by #'cddr do (incf (getf counts key 0)) finally (return counts))) (keys-to-fix (loop for (key value) on counts by #'cddr if (> value 1) collect key))) (if keys-to-fix (let ((multiple-standard-keys (intersection keys-to-fix *standard-slot-keys*))) (if multiple-standard-keys (error "Too many occurences of ~S in slot initargs ~S." multiple-standard-keys initargs) (loop with fixed-keys for (key value) on initargs by #'cddr if (member key keys-to-fix) do (nconcf (getf fixed-keys key) (list value)) else nconc (list key value) into fixed-initargs finally (return (nconc fixed-initargs fixed-keys))))) initargs))) cl-closer-mop-0.6.orig/closer-cmu.lisp0000644000175000017500000001116011317133033020160 0ustar pvaneyndpvaneynd(in-package :closer-mop) ;; In CMUCL, reader-method-class and writer-method-class are ;; not used during class initialization. The following definitions ;; correct this. (defun modify-accessors (class) (loop with reader-specializers = (list class) with writer-specializers = (list (find-class 't) class) for slotd in (class-direct-slots class) do (loop for reader in (slot-definition-readers slotd) for reader-function = (fdefinition reader) for reader-method = (find-method reader-function () reader-specializers) for initargs = (list :qualifiers () :lambda-list '(object) :specializers reader-specializers :function (method-function reader-method) :slot-definition slotd) for method-class = (apply #'reader-method-class class slotd initargs) unless (eq method-class (class-of reader-method)) do (add-method reader-function (apply #'make-instance method-class initargs))) (loop for writer in (slot-definition-writers slotd) for writer-function = (fdefinition writer) for writer-method = (find-method writer-function () writer-specializers) for initargs = (list :qualifiers () :lambda-list '(new-value object) :specializers writer-specializers :function (method-function writer-method) :slot-definition slotd) for method-class = (apply #'writer-method-class class slotd initargs) unless (eq method-class (class-of writer-method)) do (add-method writer-function (apply #'make-instance method-class initargs))))) ;; The following methods additionally create a gensym for the class name ;; unless a name is explicitly provided. AMOP requires classes to be ;; potentially anonymous. (defmethod initialize-instance :around ((class standard-class) &rest initargs &key (name (gensym))) (declare (dynamic-extent initargs)) (prog1 (apply #'call-next-method class :name name initargs) (modify-accessors class))) (defmethod initialize-instance :around ((class funcallable-standard-class) &rest initargs &key (name (gensym))) (declare (dynamic-extent initargs)) (prog1 (apply #'call-next-method class :name name initargs) (modify-accessors class))) (defmethod reinitialize-instance :after ((class standard-class) &key) (modify-accessors class)) (defmethod reinitialize-instance :after ((class funcallable-standard-class) &key) (modify-accessors class)) ;;; The following three methods ensure that the dependent protocol ;;; for generic function works. ;; The following method additionally ensures that ;; compute-discriminating-function is triggered. ; Note that for CMUCL, these methods violate the AMOP specification ; by specializing on the original standard-generic-function metaclass. However, ; this is necassary because in CMUCL, only one subclass of ; standard-generic-function can be created, and taking away that option from user ; code doesn't make a lot of sense in our context. (defmethod reinitialize-instance :after ((gf standard-generic-function) &rest initargs) (declare (dynamic-extent initargs)) (set-funcallable-instance-function gf (compute-discriminating-function gf))) ;; The following ensures that effective slot definitions have a documentation in CMUCL. (defmethod compute-effective-slot-definition :around ((class standard-class) name direct-slot-definitions) (let ((effective-slot (call-next-method))) (loop for direct-slot in direct-slot-definitions for documentation = (documentation direct-slot 't) when documentation do (setf (documentation effective-slot 't) documentation) (loop-finish)) effective-slot)) ;; In CMUCL, TYPEP and SUBTYPEP don't work as expected ;; in conjunction with class metaobjects. (defgeneric typep (object type) (:method (object type) (cl:typep object type)) (:method (object (type class)) (cl:typep object (class-name type)))) (defgeneric subtypep (type1 type2) (:method (type1 type2) (cl:subtypep type1 type2)) (:method ((type1 class) type2) (cl:subtypep (class-name type1) type2)) (:method (type1 (type2 class)) (cl:subtypep type1 (class-name type2))) (:method ((type1 class) (type2 class)) (cl:subtypep (class-name type1) (class-name type2)))) (eval-when (:compile-toplevel :load-toplevel :execute) (pushnew :closer-mop *features*)) cl-closer-mop-0.6.orig/closer-mop.asd0000644000175000017500000000316011317133033017770 0ustar pvaneyndpvaneynd(asdf:defsystem #:closer-mop :name "Closer to MOP" :author "Pascal Costanza" :version "0.6" :licence " Copyright (c) 2005 - 2009 Pascal Costanza Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the \"Software\"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. " :components ((:file "closer-mop-packages") (:file "closer-mop-shared" :depends-on ("closer-mop-packages")) (:file #+allegro "closer-allegro" #+clisp "closer-clisp" #+clozure "closer-clozure" #+cmu "closer-cmu" #+ecl "closer-ecl" #+lispworks "closer-lispworks" #+mcl "closer-mcl" #+sbcl "closer-sbcl" #+scl "closer-scl" :depends-on ("closer-mop-packages" "closer-mop-shared")))) cl-closer-mop-0.6.orig/supported-cls.txt0000644000175000017500000000031411317133033020562 0ustar pvaneyndpvaneyndAllegro 8.1 CLisp 2.48 Clozure Common Lisp 1.4 CMU Common Lisp 20a Embeddable Common Lisp 9.12.3 LispWorks 5.1.1 Personal Edition LispWorks 5.1.2 Professional Edition MCL 5.2.1 SBCL 1.0.34 Scieneer 1.3.9 cl-closer-mop-0.6.orig/test/0002755000175000017500000000000011317133033016200 5ustar pvaneyndpvaneyndcl-closer-mop-0.6.orig/test/jeffs-code.lisp0000644000175000017500000001731211317133033021100 0ustar pvaneyndpvaneynd;;; Jeff Caldwell 2004-04-16 ;;; LWL 4.3 ;;; ;;; To reproduce the issues I have come across: ;;; ;;; 1. (asdf:oos 'asdf:load-op 'closer-mop) ;;; 2. (compile-file "c2mop-attributes.lisp" :load t) ;;; 3. (in-package #:c2mop-test) ;;; C2MOP-TEST> (setq cr (make-instance 'credit-rating)) ;;; => Stack overflow (stack size 16000). ;;; ;;; (In this code, I accidently took out the format statements ;;; creating the output below. You may wish to put them back ;;; in the slot-value-using-class and (setf slot-value-using-class) ;;; methods at the bottom of this file.) ;;; ;;; slot-value-using-class class # ;;; object # slot-name ALL-ATTRIBUTES-2382 ;;; slot-value-using-class class # ;;; object # slot-name LEVEL ;;; slot-value-using-class class # ;;; object # ;;; slot-name # ;;; slot-value-using-class class # ;;; object # slot-name LEVEL ;;; slot-value-using-class class # ;;; object # ;;; slot-name # ;;; slot-value-using-class class # ;;; object # slot-name LEVEL ;;; slot-value-using-class class # ;;; object # ;;; slot-name # ;;; ... ;;; ;;; Note that it alternates between slot-name LEVEL and ;;; slot-name # ;;; The slot # is ;;; missing from # (of class #), when reading the value. ;;; ;;; At this point you also can remove the slot-value-using-class and ;;; setf slot-value-using-class methods. They were no-ops in this ;;; example, something I had run across in other code. I left them ;;; here to show the recursive stack overflow. Now that it is "fixed", ;;; we are left with the missing slot problem above. ;;; (The problem above is somewhat different from what I reported ;;; in my first email but the error above is what I'm getting now ;;; with this example.) ;;; ;;; Simply using the LW MOP, instead of using closer-mop, ;;; "fixes" the problem above. Quit using closer-mop and revert ;;; to the LW-only MOP. Change the defpackage to ;;; ;;; (defpackage #:c2mop-test ;;; (:use :cl :cl-user :clos)) ;;; ;;; (cl-user::quit) ;; Make really sure everything's fresh ;;; M-x slime ;;; (compile-file "c2mop-attributes.lisp" :load t) ;;; CL-USER> (in-package #:c2mop-test) ;;; # ;;; C2MOP-TEST> (setq cr (make-instance 'credit-rating)) ;;; # ;;; C2MOP-TEST> (setf (level cr) 42) ;;; 42 ;;; C2MOP-TEST> (level cr) ;;; 42 ;;; C2MOP-TEST> (setf (slot-attribute cr 'level 'date-set) 20040416) ;;; 20040416 ;;; C2MOP-TEST> (slot-attribute cr 'level 'date-set) ;;; 20040416 ;;; ;;; (defpackage #:c2mop-test ; (:use :cl :cl-user :clos) (:use :cl :cl-user :closer-mop) (:shadowing-import-from :closer-mop #:defclass #:defmethod #:standard-class #:ensure-generic-function #:defgeneric #:standard-generic-function #:class-name) ) (in-package #:c2mop-test) (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *all-attributes* (gensym "ALL-ATTRIBUTES-")) (defvar *current-direct-slot-definitions* nil) (defclass attributes-class (standard-class) ()) (defclass attributes-mixin (standard-slot-definition) ((attributes :initarg :attributes :accessor slot-definition-attributes :initform nil))) (defclass attributes-direct-slot-definition (standard-direct-slot-definition attributes-mixin) ()) (defclass attributes-effective-slot-definition (standard-effective-slot-definition attributes-mixin) ()) (defmethod effective-slot-definition-class ((class attributes-class) &rest initargs) (find-class 'attributes-effective-slot-definition)) (defmethod compute-effective-slot-definition ((class attributes-class) name direct-slots) (let* ((normal-slot (call-next-method))) (setf (slot-definition-attributes normal-slot) (remove-duplicates (apply #'append (mapcar #'slot-definition-attributes direct-slots)))) normal-slot)) (defmethod direct-slot-definition-class ((class attributes-class) &rest initargs) (find-class 'attributes-direct-slot-definition)) (defmethod process-a-slot-option ((class attributes-class) option value already-processed-options slot) (princ "process-a-slot-option") (princ option) (if (eq option :attributes) (list* :attributes `',value already-processed-options) (call-next-method))) (defmethod compute-slots ((class attributes-class)) (let* ((normal-slots (call-next-method)) (alist (mapcar (lambda (slot) (cons (slot-definition-name slot) (mapcar (lambda (attr) (cons attr nil)) (slot-definition-attributes slot)))) normal-slots))) (cons (make-instance 'attributes-effective-slot-definition :name *all-attributes* :initform alist :initfunction (lambda () alist)) normal-slots))) (defun slot-attribute (instance slot-name attribute) (cdr (slot-attribute-bucket instance slot-name attribute))) (defun (setf slot-attribute) (new-value instance slot-name attribute) (setf (cdr (slot-attribute-bucket instance slot-name attribute)) new-value)) (defun slot-attribute-bucket (instance slot-name attribute) (let* ((all-buckets (slot-value instance *all-attributes*)) (slot-bucket (assoc slot-name all-buckets))) (unless slot-bucket (error "Slot ~S of ~S has no attributes." slot-name instance)) (let ((attr-bucket (assoc attribute (cdr slot-bucket)))) (unless attr-bucket (error "Slot ~S of ~S has no attribute ~S." slot-name instance attribute)) attr-bucket))) (defmethod clos:slot-value-using-class ((class attributes-class) object (slot-name attributes-effective-slot-definition)) (call-next-method)) (defmethod (setf clos:slot-value-using-class) (value (class attributes-class) object (slot-name attributes-effective-slot-definition)) (call-next-method)) ) ; eval-when (defclass credit-rating () ((level :attributes (date-set time-set) :accessor level) (desc :accessor desc)) (:metaclass attributes-class)) cl-closer-mop-0.6.orig/closer-mcl.lisp0000644000175000017500000000330211317133033020146 0ustar pvaneyndpvaneynd(in-package :closer-mop) ;; We need a new standard-class for various things. (defclass standard-class (cl:standard-class) ()) (define-validate-superclass-method standard-class cl:standard-class) (defmethod ccl::create-reader-method-function ((class standard-class) (reader-method-class standard-reader-method) (dslotd standard-direct-slot-definition)) (let ((slot-name (slot-definition-name dslotd))) (compile nil `(lambda (object) (slot-value object ',slot-name))))) (defmethod ccl::create-writer-method-function ((class standard-class) (writer-method-class standard-writer-method) (dslotd standard-direct-slot-definition)) (let ((slot-name (slot-definition-name dslotd))) (compile nil `(lambda (new-value object) (setf (slot-value object ',slot-name) new-value))))) (defgeneric typep (object type) (:method (object type) (cl:typep object type)) (:method (object (type class)) (member (class-of object) (class-precedence-list type)))) (defgeneric subtypep (type1 type2) (:method (type1 type2) (cl:subtypep type1 type2)) (:method ((type1 class) (type2 symbol)) (let ((class2 (find-class type2 nil))) (if class2 (member class2 (class-precedence-list type1)) (cl:subtypep type1 type2)))) (:method ((type1 symbol) (type2 class)) (let ((class1 (find-class type1 nil))) (if class1 (member type2 (class-precedence-list class1)) (cl:subtypep type1 type2)))) (:method ((type1 class) (type2 class)) (member type2 (class-precedence-list type1)))) (eval-when (:compile-toplevel :load-toplevel :execute) (pushnew :closer-mop *features*)) cl-closer-mop-0.6.orig/features.lisp0000644000175000017500000004306711317133033017740 0ustar pvaneyndpvaneynd:allegro8.1 ((:class-default-initargs) (:class-direct-default-initargs) (:compute-default-initargs) ; -> :compute-default-initargs-allegro (:default-superclass-for-funcallable-standard-class-is-funcallable-standard-object) (:defgeneric-calls-find-method-combination) (:defmethod-calls-make-method-lambda fixed) (:dependent-protocol-for-generic-functions fixed) (:extensible-allocation fixed) (:function-invocation-calls-compute-applicable-methods fixed) (:function-invocation-calls-compute-applicable-methods-using-classes fixed) (:function-invocation-calls-compute-effective-method fixed) (:generic-function-argument-precedence-order-returns-required-arguments fixed) (:make-method-lambda fixed) (:method-functions-take-processed-parameters fixed) (:method-lambdas-are-processed fixed) (:reinitialize-instance-calls-compute-discriminating-function fixed) (:setf-class-name-calls-reinitialize-instance) (:setf-generic-function-name-calls-reinitialize-instance) (:slot-makunbound-using-class-specialized-on-slot-definition fixed) (:standard-class-and-funcallable-standard-class-are-compatible) (:subclasses-of-built-in-class-do-not-inherit-exported-slots) (:subclasses-of-forward-referenced-class-do-not-inherit-exported-slots) (:subclasses-of-funcallable-standard-class-do-not-inherit-exported-slots) (:subclasses-of-method-combination-do-not-inherit-exported-slots) (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) (:subclasses-of-standard-class-do-not-inherit-exported-slots) (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) (:subclasses-of-standard-method-do-not-inherit-exported-slots) (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots) (:t-is-always-a-valid-superclass)) :clisp2.48 ((:accessor-method-initialized-with-function) (:add-method-calls-compute-discriminating-function) (:compute-slots-requested-slot-order-honoured) (:defmethod-calls-make-method-lambda fixed) (:forward-referenced-class-changed-by-change-class) (:initialize-instance-calls-compute-discriminating-function) (:make-method-lambda fixed) (:method-initialized-with-function) (:method-lambdas-are-processed fixed) (:reinitialize-instance-calls-compute-discriminating-function) (:remove-method-calls-compute-discriminating-function) (:subclasses-of-method-combination-do-not-inherit-exported-slots)) :clozure-common-lisp1.4 ((:add-method-calls-compute-discriminating-function fixed) (:compute-slots-requested-slot-order-honoured) (:defmethod-calls-generic-function-method-class fixed) (:defmethod-calls-make-method-lambda fixed) (:discriminating-functions-can-be-closures fixed) (:discriminating-functions-can-be-funcalled fixed) (:function-invocation-calls-compute-applicable-methods fixed) (:function-invocation-calls-compute-applicable-methods-using-classes fixed) (:function-invocation-calls-compute-effective-method fixed) (:generic-functions-can-be-empty fixed) (:initialize-instance-calls-compute-discriminating-function fixed) (:make-method-lambda fixed) (:method-functions-take-processed-parameters fixed) (:method-lambdas-are-processed fixed) (:reinitialize-instance-calls-compute-discriminating-function fixed) (:reinitialize-instance-calls-finalize-inheritance fixed) (:reinitialize-lambda-list-reinitializes-argument-precedence-order fixed) (:remove-method-calls-compute-discriminating-function fixed) (:slot-definition-documentation fixed) (:subclasses-of-direct-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-effective-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-generic-function-do-not-inherit-exported-slots) (:subclasses-of-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slot) (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) (:subclasses-of-standard-method-do-not-inherit-exported-slots) (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots)) :cmu20a ((:accessor-method-initialized-with-function fixed) (:accessor-method-initialized-with-lambda-list fixed) (:accessor-method-initialized-with-slot-definition fixed) (:accessor-method-initialized-with-specializers fixed) (:anonymous-classes fixed) (:class-default-initargs) (:class-direct-default-initargs) (:class-initialization-calls-reader-method-class fixed) (:class-initialization-calls-writer-method-class fixed) (:discriminating-functions-can-be-closures) (:discriminating-functions-can-be-funcalled) (:documentation-passed-to-effective-slot-definition-class) (:effective-slot-definition-initialized-with-documentation) (:method-initialized-with-function) (:multiple-slot-options-passed-as-list-to-direct-slot-definition-class) ; fix with fix-slot-initargs (:reinitialize-instance-calls-compute-discriminating-function fixed) (:reinitialize-instance-calls-finalize-inheritance) (:setf-class-name-calls-reinitialize-instance) (:setf-generic-function-name-calls-reinitialize-instance) (:slot-definition-documentation fixed) (:standard-class-and-funcallable-standard-class-are-compatible) (:subclasses-of-built-in-class-do-not-inherit-exported-slots) (:subclasses-of-class-do-not-inherit-exported-slots) (:subclasses-of-direct-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-effective-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-eql-specializer-do-not-inherit-exported-slots) (:subclasses-of-forward-referenced-class-do-not-inherit-exported-slots) (:subclasses-of-funcallable-standard-class-do-not-inherit-exported-slots) (:subclasses-of-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-specializer-do-not-inherit-exported-slots) (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) (:subclasses-of-standard-class-do-not-inherit-exported-slots) (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) (:subclasses-of-standard-method-do-not-inherit-exported-slots) (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots)) :ecl9.12.3 ((:add-direct-method fixed) (:add-method-calls-add-direct-method fixed) (:add-method-calls-compute-discriminating-function fixed) (:add-method-calls-remove-method fixed) (:add-method-updates-specializer-direct-generic-functions fixed) (:add-method-updates-specializer-direct-methods fixed) (:class-initialization-calls-reader-method-class) (:class-initialization-calls-writer-method-class) (:class-reinitialization-calls-remove-direct-subclass fixed) (:classes-are-always-their-own-valid-superclasses fixed) (:compute-applicable-methods-is-generic fixed) (:compute-applicable-methods-using-classes fixed) (:compute-effective-method-is-generic fixed) (:defgeneric-calls-find-method-combination) (:defmethod-calls-generic-function-method-class fixed) (:defmethod-calls-make-method-lambda fixed) (:dependent-protocol-for-classes fixed) (:dependent-protocol-for-generic-functions fixed) (:discriminating-functions-can-be-closures fixed) (:discriminating-functions-can-be-funcalled fixed) (:eql-specializer) ;; partially fixed (:eql-specializer-object fixed) (:eql-specializers-are-objects) (:extract-lambda-list fixed) (:extract-specializer-names fixed) (:find-method-combination) ;; partially fixed (:find-method-is-generic fixed) (:function-invocation-calls-compute-applicable-methods fixed) (:function-invocation-calls-compute-applicable-methods-using-classes fixed) (:function-invocation-calls-compute-effective-method fixed) (:generic-function-declarations fixed) (:generic-function-method-class-is-generic fixed) (:generic-functions-can-be-empty fixed) (:initialize-instance-calls-compute-discriminating-function fixed) (:intern-eql-specializer fixed) (:make-method-lambda fixed) (:metaobject) (:method-functions-take-processed-parameters) (:method-initialized-with-documentation fixed) (:method-lambdas-are-processed) (:multiple-slot-options-passed-as-list-to-direct-slot-definition-class) (:reinitialize-instance-calls-compute-discriminating-function fixed) (:remove-direct-method fixed) (:remove-method-calls-compute-discriminating-function fixed) (:remove-method-calls-remove-direct-method fixed) (:remove-method-is-generic fixed) (:setf-class-name-calls-reinitialize-instance fixed) (:setf-generic-function-name fixed) (:setf-generic-function-name-calls-reinitialize-instance fixed) (:slot-reader-calls-slot-value-using-class fixed) (:slot-writer-calls-slot-value-using-class fixed) (:specializer) (:specializer-direct-generic-functions fixed) (:specializer-direct-methods fixed) (:standard-class-and-funcallable-standard-class-are-compatible fixed) (:subclasses-of-built-in-class-do-not-inherit-exported-slots) (:subclasses-of-class-do-not-inherit-exported-slots) (:subclasses-of-direct-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-effective-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-forward-referenced-class-do-not-inherit-exported-slots) (:subclasses-of-funcallable-standard-class-do-not-inherit-exported-slots) (:subclasses-of-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) (:subclasses-of-standard-class-do-not-inherit-exported-slots) (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) (:subclasses-of-standard-method-do-not-inherit-exported-slots) (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots) (:t-is-always-a-valid-superclass fixed) (:validate-superclass fixed)) :lispworks5.1-5.1.2 ((:add-method-calls-compute-discriminating-function) (:add-method-updates-specializer-direct-generic-functions fixed) (:class-default-initargs) (:class-direct-default-initargs) (:compute-applicable-methods-using-classes fixed) (:compute-default-initargs) (:defgeneric-calls-find-method-combination) (:eql-specializer) ; partially fixed (:eql-specializer-object fixed) (:eql-specializers-are-objects) (:finalize-inheritance-calls-compute-default-initargs) (:find-method-combination fixed) ; partially (:funcallable-standard-instance-access fixed) (:function-invocation-calls-compute-applicable-methods fixed) (:function-invocation-calls-compute-applicable-methods-using-classes fixed) (:initialize-instance-calls-compute-discriminating-function) (:intern-eql-specializer fixed) ; partially (:make-method-lambda fixed) (:method-functions-take-processed-parameters fixed) (:reinitialize-instance-calls-compute-discriminating-function) (:remove-method-calls-compute-discriminating-function) (:setf-slot-value-using-class-specialized-on-slot-definition fixed) (:slot-boundp-using-class-specialized-on-slot-definition fixed) (:slot-makunbound-using-class-specialized-on-slot-definition fixed) (:slot-reader-calls-slot-value-using-class fixed) (:slot-value-using-class-specialized-on-slot-definition fixed) (:slot-writer-calls-slot-value-using-class fixed) (:specializer) (:specializer-direct-generic-functions fixed) (:standard-class-and-funcallable-standard-class-are-compatible) (:standard-instance-access fixed) (:subclasses-of-built-in-class-do-not-inherit-exported-slots fixed) (:subclasses-of-class-do-not-inherit-exported-slots fixed) (:subclasses-of-direct-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-effective-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-forward-referenced-class-do-not-inherit-exported-slots fixed) (:subclasses-of-funcallable-standard-class-do-not-inherit-exported-slots fixed) (:subclasses-of-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) (:subclasses-of-standard-class-do-not-inherit-exported-slots fixed) (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) (:subclasses-of-standard-method-do-not-inherit-exported-slots) (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots)) :mcl5.2.1 ((:add-method-calls-compute-discriminating-function) (:compute-applicable-methods-using-classes) (:compute-slots-requested-slot-order-honoured) (:default-superclass-for-funcallable-standard-class-is-funcallable-standard-object fixed) (:defmethod-calls-generic-function-method-class) (:defmethod-calls-make-method-lambda) (:discriminating-functions-can-be-closures) (:discriminating-functions-can-be-funcalled) (:funcallable-instance-functions-can-be-closures) (:funcallable-standard-object fixed) (:function-invocation-calls-compute-applicable-methods) (:function-invocation-calls-compute-applicable-methods-using-classes) (:function-invocation-calls-compute-effective-method) (:generic-function-declarations) (:generic-function-initialized-with-declarations) (:generic-functions-can-be-empty) (:initialize-instance-calls-compute-discriminating-function) (:make-method-lambda) (:method-functions-take-processed-parameters) (:method-lambdas-are-processed) (:reinitialize-instance-calls-compute-discriminating-function) (:reinitialize-instance-calls-finalize-inheritance) (:reinitialize-lambda-list-reinitializes-argument-precedence-order) (:remove-method-calls-compute-discriminating-function) (:set-funcallable-instance-function) (:setf-generic-function-name) (:setf-generic-function-name-calls-reinitialize-instance) (:slot-reader-calls-slot-value-using-class fixed) (:slot-writer-calls-slot-value-using-class fixed) (:subclasses-of-direct-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-effective-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) (:subclasses-of-standard-method-do-not-inherit-exported-slots) (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots)) :sbcl1.0.34 #| all features implemented |# :scl1.3.9 ((:add-direct-method fixed) (:add-method-calls-add-direct-method fixed) (:class-default-initargs) (:class-direct-default-initargs) (:compute-effective-method) (:compute-effective-method-is-generic) (:defmethod-calls-make-method-lambda) (:dependent-protocol-for-classes fixed) (:dependent-protocol-for-generic-functions fixed) (:discriminating-functions-can-be-funcalled) (:eql-specializer) (:extensible-allocation) (:funcallable-standard-instance-access) (:function-invocation-calls-compute-applicable-methods) (:function-invocation-calls-compute-effective-method) (:make-method-lambda) (:method-lambdas-are-processed) (:multiple-slot-options-passed-as-list-to-direct-slot-definition-class) (:reinitialize-instance-calls-compute-discriminating-function) (:remove-direct-method fixed) (:remove-method-calls-remove-direct-method fixed) (:setf-class-name-calls-reinitialize-instance) (:setf-generic-function-name-calls-reinitialize-instance) (:specializer) (:standard-class-and-funcallable-standard-class-are-compatible) (:standard-instance-access) (:subclasses-of-built-in-class-do-not-inherit-exported-slots) (:subclasses-of-class-do-not-inherit-exported-slots) (:subclasses-of-forward-referenced-class-do-not-inherit-exported-slots) (:subclasses-of-funcallable-standard-class-do-not-inherit-exported-slots) (:subclasses-of-method-combination-do-not-inherit-exported-slots) (:subclasses-of-standard-accessor-method-do-not-inherit-exported-slots) (:subclasses-of-standard-class-do-not-inherit-exported-slots) (:subclasses-of-standard-direct-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-standard-effective-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-standard-generic-function-do-not-inherit-exported-slots) (:subclasses-of-standard-method-do-not-inherit-exported-slots) (:subclasses-of-standard-reader-method-do-not-inherit-exported-slots) (:subclasses-of-standard-slot-definition-do-not-inherit-exported-slots) (:subclasses-of-standard-writer-method-do-not-inherit-exported-slots)) cl-closer-mop-0.6.orig/closer-sbcl.lisp0000644000175000017500000000016511317133033020322 0ustar pvaneyndpvaneynd(in-package :closer-mop) (eval-when (:compile-toplevel :load-toplevel :execute) (pushnew :closer-mop *features*)) cl-closer-mop-0.6.orig/closer-allegro.lisp0000644000175000017500000001111311317133033021017 0ustar pvaneyndpvaneynd(in-package :closer-mop) ;; We need a new standard-class for various things. (defclass standard-class (cl:standard-class excl:lockable-object) ((valid-slot-allocations :initform '(:instance :class) :accessor valid-slot-allocations :reader excl::valid-slot-allocation-list))) (define-validate-superclass-method standard-class cl:standard-class) ;; Allegro defines an extra check for :allocation kinds. AMOP expects any kind to be ;; permissible, though. This is corrected here. (cl:defmethod direct-slot-definition-class :before ((class standard-class) &key allocation &allow-other-keys) (unless (eq (class-of class) (find-class 'standard-class)) (excl:with-locked-object (class :non-smp :without-scheduling) (pushnew allocation (valid-slot-allocations class))))) ;;; In Allegro, slot-boundp-using-class and slot-makunbound-using-class are specialized ;;; on slot names instead of effective slot definitions. In order to fix this, ;;; we need to rewire the slot access protocol. #-(version>= 8 1) (progn (cl:defmethod slot-boundp-using-class ((class standard-class) object (slot symbol)) (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) (let ((slotd (find slot (class-slots class) :test #'eq :key #'slot-definition-name))) (if slotd (slot-boundp-using-class class object slotd) (slot-missing class object slot 'slot-boundp)))) (cl:defmethod slot-boundp-using-class ((class standard-class) object (slotd standard-effective-slot-definition)) (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) (slot-boundp-using-class (load-time-value (class-prototype (find-class 'cl:standard-class))) object (slot-definition-name slotd)))) (cl:defmethod slot-makunbound-using-class ((class standard-class) object (slot symbol)) (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) (let ((slotd (find slot (class-slots class) :test #'eq :key #'slot-definition-name))) (if slotd (slot-makunbound-using-class class object slotd) (slot-missing class object slot 'slot-makunbound)))) (cl:defmethod slot-makunbound-using-class ((class standard-class) object (slotd standard-effective-slot-definition)) (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) (slot-makunbound-using-class (load-time-value (class-prototype (find-class 'cl:standard-class))) object (slot-definition-name slotd))) ;;; New generic functions. (cl:defmethod initialize-instance :around ((gf standard-generic-function) &rest initargs &key (method-class nil method-class-p)) (declare (dynamic-extent initargs)) (if (and method-class-p (symbolp method-class)) (apply #'call-next-method gf :method-class (find-class method-class) initargs) (call-next-method))) (cl:defmethod reinitialize-instance :around ((gf standard-generic-function) &rest initargs &key (method-class nil method-class-p)) (declare (dynamic-extent initargs)) (if (and method-class-p (symbolp method-class)) (apply #'call-next-method gf :method-class (find-class method-class) initargs) (call-next-method))) ;;; The following three methods ensure that the dependent protocol ;;; for generic function works. ;; The following method additionally ensures that ;; compute-discriminating-function is triggered. (cl:defmethod reinitialize-instance :after ((gf standard-generic-function) &rest initargs) (declare (dynamic-extent initargs)) (set-funcallable-instance-function gf (compute-discriminating-function gf)) (map-dependents gf (lambda (dep) (apply #'update-dependent gf dep initargs)))) (cl:defmethod add-method :after ((gf standard-generic-function) method) (map-dependents gf (lambda (dep) (update-dependent gf dep 'add-method method)))) (cl:defmethod remove-method :after ((gf standard-generic-function) method) (map-dependents gf (lambda (dep) (update-dependent gf dep 'remove-method method)))) ;; The following method ensures that we get only the required arguments ;; from generic-function-argument-precedence-order (cl:defgeneric generic-function-argument-precedence-order (gf) (:method ((gf generic-function)) (required-args (mop:generic-function-argument-precedence-order gf)))) (eval-when (:compile-toplevel :load-toplevel :execute) (pushnew :closer-mop *features*)) cl-closer-mop-0.6.orig/closer-lispworks.lisp0000644000175000017500000003743211317133033021443 0ustar pvaneyndpvaneynd(in-package :closer-mop) ;; We need a new standard-class for various things. (defclass standard-class (cl:standard-class) ()) (define-validate-superclass-method standard-class cl:standard-class) ;; We need a new funcallable-standard-class for various things. (defclass funcallable-standard-class (clos:funcallable-standard-class) ()) (define-validate-superclass-method funcallable-standard-class clos:funcallable-standard-class) #-lispworks4 (cl:defmethod validate-superclass ((class funcallable-standard-class) (superclass (eql (find-class 'funcallable-standard-object)))) t) ;; We also need a new funcallable-standard-object because the default one ;; is not an instance of clos:funcallable-standard-class. #+lispworks4 (defclass funcallable-standard-object (clos:funcallable-standard-object) () (:metaclass clos:funcallable-standard-class)) ;; The following code ensures that possibly incorrect lists of direct ;; superclasses are corrected. #+lispworks4 (defun modify-superclasses (direct-superclasses &optional (standardp t)) (if (null direct-superclasses) (list (if standardp (find-class 'standard-object) (find-class 'funcallable-standard-object))) (let ((standard-object (if standardp (find-class 'standard-object) (find-class 'clos:funcallable-standard-object)))) (if (eq (car (last direct-superclasses)) standard-object) (if standardp direct-superclasses (append (butlast direct-superclasses) (list (find-class 'funcallable-standard-object)))) (remove standard-object direct-superclasses))))) ;; During class re/initialization, we take care of the following things: ;; - Optimization of slot accessors is deactivated. ;; - Lists of direct superclasses are corrected. ;; - Removal of direct subclasses. (defun optimize-slot-access-p (class) (flet ((applicablep (specializer) (if (consp specializer) (eql class (eql-specializer-object specializer)) (subclassp (class-of class) specializer)))) (and (loop for method in (generic-function-methods #'slot-value-using-class) never (applicablep (first (method-specializers method)))) (loop for method in (generic-function-methods #'(setf slot-value-using-class)) never (applicablep (second (method-specializers method))))))) (cl:defmethod initialize-instance :around ((class standard-class) &rest initargs #+lispworks4 &key #+lispworks4 (direct-superclasses ())) (declare (dynamic-extent initargs)) (apply #'call-next-method class #+lispworks4 :direct-superclasses #+lispworks4 (modify-superclasses direct-superclasses) :optimize-slot-access (optimize-slot-access-p class) initargs)) (cl:defmethod reinitialize-instance :around ((class standard-class) &rest initargs #+lispworks4 &key #+lispworks4 (direct-superclasses () direct-superclasses-p)) (declare (dynamic-extent initargs)) #+lispworks4 (progn (when direct-superclasses-p (setq direct-superclasses (modify-superclasses direct-superclasses)) (loop for superclass in (copy-list (class-direct-superclasses class)) unless (member superclass direct-superclasses) do (remove-direct-subclass superclass class))) (if direct-superclasses-p (apply #'call-next-method class :direct-superclasses direct-superclasses :optimize-slot-access (optimize-slot-access-p class) initargs) (apply #'call-next-method class :optimize-slot-access (optimize-slot-access-p class) initargs))) #-lispworks4 (apply #'call-next-method class :optimize-slot-access (optimize-slot-access-p class) initargs)) (cl:defmethod initialize-instance :around ((class funcallable-standard-class) &rest initargs #+lispworks4 &key #+lispworks4 (direct-superclasses ())) (declare (dynamic-extent initargs)) (apply #'call-next-method class #+lispworks4 :direct-superclasses #+lispworks4 (modify-superclasses direct-superclasses nil) :optimize-slot-access (optimize-slot-access-p class) initargs)) (cl:defmethod reinitialize-instance :around ((class funcallable-standard-class) &rest initargs #+lispworks4 &key #+lispworks4 (direct-superclasses () direct-superclasses-p)) (declare (dynamic-extent initargs)) #+lispworks4 (progn (when direct-superclasses-p (setq direct-superclasses (modify-superclasses direct-superclasses nil)) (loop for superclass in (copy-list (class-direct-superclasses class)) unless (member superclass direct-superclasses) do (remove-direct-subclass superclass class))) (if direct-superclasses-p (apply #'call-next-method class :direct-superclasses direct-superclasses :optimize-slot-access (optimize-slot-access-p class) initargs) (apply #'call-next-method class :optimize-slot-access (optimize-slot-access-p class) initargs))) #-lispworks4 (apply #'call-next-method class :optimize-slot-access (optimize-slot-access-p class) initargs)) ;; The following is necessary for forward-referenced-classes. ;; Since we replace the original funcallable-standard-object with ;; a new one, we have to prevent LispWorks from trying to use ;; the original one when forward-ferenced-classes are resolved. #+lispworks4 (cl:defmethod change-class :around ((class forward-referenced-class) (new-class funcallable-standard-class) &rest initargs &key (direct-superclasses ())) (declare (dynamic-extent initargs)) (apply #'call-next-method class new-class :optimize-slot-access (optimize-slot-access-p new-class) :direct-superclasses (modify-superclasses direct-superclasses nil) initargs)) ;;; In LispWorks, the slot accessors (slot-value-using-class, etc.) are specialized ;;; on slot names instead of effective slot definitions. In order to fix this, ;;; we need to rewire the slot access protocol. (cl:defmethod slot-value-using-class ((class standard-class) object (slot symbol)) (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) (let ((slotd (find slot (class-slots class) :test #'eq :key #'slot-definition-name))) (if slotd (slot-value-using-class class object slotd) (slot-missing class object slot 'slot-value)))) (cl:defmethod slot-value-using-class ((class standard-class) object (slotd standard-effective-slot-definition)) (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) (slot-value-using-class (load-time-value (class-prototype (find-class 'cl:standard-class))) object (slot-definition-name slotd))) (cl:defmethod (setf slot-value-using-class) (new-value (class standard-class) object (slot symbol)) (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) (let ((slotd (find slot (class-slots class) :test #'eq :key #'slot-definition-name))) (if slotd (setf (slot-value-using-class class object slotd) new-value) (slot-missing class object slot 'setf new-value)))) (cl:defmethod (setf slot-value-using-class) (new-value (class standard-class) object (slotd standard-effective-slot-definition)) (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) (setf (slot-value-using-class (load-time-value (class-prototype (find-class 'cl:standard-class))) object (slot-definition-name slotd)) new-value)) (cl:defmethod slot-boundp-using-class ((class standard-class) object (slot symbol)) (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) (let ((slotd (find slot (class-slots class) :test #'eq :key #'slot-definition-name))) (if slotd (slot-boundp-using-class class object slotd) (slot-missing class object slot 'slot-boundp)))) (cl:defmethod slot-boundp-using-class ((class standard-class) object (slotd standard-effective-slot-definition)) (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) (slot-boundp-using-class (load-time-value (class-prototype (find-class 'cl:standard-class))) object (slot-definition-name slotd))) (cl:defmethod slot-makunbound-using-class ((class standard-class) object (slot symbol)) (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) (let ((slotd (find slot (class-slots class) :test #'eq :key #'slot-definition-name))) (if slotd (slot-makunbound-using-class class object slotd) (slot-missing class object slot 'slot-makunbound)))) (cl:defmethod slot-makunbound-using-class ((class standard-class) object (slotd standard-effective-slot-definition)) (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0))) (slot-makunbound-using-class (load-time-value (class-prototype (find-class 'cl:standard-class))) object (slot-definition-name slotd))) ;; In LispWorks, eql specializers are lists. We cannot change this ;; but we can soften some of the incompatibilities. (deftype eql-specializer () '(or eql-specializer* (satisfies clos:eql-specializer-p))) (cl:defgeneric eql-specializer-object (eql-specializer) (:method ((cons cons)) (if (clos:eql-specializer-p cons) (cadr cons) (error "~S is not an eql-specializer." cons)))) (defun intern-eql-specializer (object) `(eql ,object)) (defclass eql-specializer* (metaobject) ((obj :reader eql-specializer-object :initarg eso :initform (error "Use intern-eql-specializer to create eql-specializers.")) (direct-methods :reader specializer-direct-methods :accessor es-direct-methods :initform ()))) (defvar *eql-specializers* (make-hash-table :weak-kind :value)) (defun intern-eql-specializer* (object) (or (gethash object *eql-specializers*) (with-hash-table-locked *eql-specializers* (or (gethash object *eql-specializers*) (setf (gethash object *eql-specializers*) (make-instance 'eql-specializer* 'eso object)))))) (cl:defmethod add-direct-method ((specializer eql-specializer*) (method method)) (pushnew method (es-direct-methods specializer))) (cl:defmethod remove-direct-method ((specializer eql-specializer*) (method method)) (removef (es-direct-methods specializer) method)) (cl:defgeneric specializer-direct-generic-functions (specializer) (:method ((class class)) (remove-duplicates (mapcar #'method-generic-function (specializer-direct-methods class)))) (:method ((eql-specializer eql-specializer*)) (remove-duplicates (mapcar #'method-generic-function (specializer-direct-methods eql-specializer)))) (:method ((cons cons)) (specializer-direct-generic-functions (intern-eql-specializer* (eql-specializer-object cons))))) ;; The following method ensures that remove-method is called. #+lispworks4 (cl:defmethod add-method :before ((gf standard-generic-function) (method method)) (when-let (old-method (find-method gf (method-qualifiers method) (method-specializers method) nil)) (remove-method gf old-method))) ;; The following two methods ensure that add/remove-direct-method is called, ;; and that the dependent protocol for generic function works. (cl:defmethod add-method :after ((gf standard-generic-function) (method method)) (dolist (specializer (method-specializers method)) (if (consp specializer) (add-direct-method (intern-eql-specializer* (eql-specializer-object specializer)) method) #+lispworks4 (add-direct-method specializer method))) #+lispworks4.3 (map-dependents gf (lambda (dep) (update-dependent gf dep 'add-method method)))) (cl:defmethod remove-method :after ((gf standard-generic-function) (method method)) (dolist (specializer (method-specializers method)) (if (consp specializer) (remove-direct-method (intern-eql-specializer* (eql-specializer-object specializer)) method) #+lispworks4 (remove-direct-method specializer method))) #+lispworks4.3 (map-dependents gf (lambda (dep) (update-dependent gf dep 'remove-method method)))) (cl:defgeneric find-method-combination (gf combi combi-options) (:method ((gf generic-function) (combi symbol) combi-options) (when combi-options (error "This implementation of find-method-combination cannot handle method combination options.")) (clos::find-a-method-combination-type combi))) ;; "Native" make-method-lambda. (cl:defmethod make-method-lambda ((gf generic-function) (method standard-method) lambda-expression environment) (destructuring-bind (lambda (&rest args) &body body) lambda-expression (declare (ignore lambda)) (loop with documentation = :unbound for (car . cdr) = body then cdr while (or (and cdr (stringp car)) (and (consp car) (eq (car car) 'declare))) if (stringp car) do (setf documentation (if (eq documentation :unbound) car (warn "Too many documentation strings in lambda expression ~S." lambda-expression))) else append (loop for declaration in (cdr car) if (eq (car declaration) 'ignore) collect `(ignorable ,@(cdr declaration)) and collect `(dynamic-extent ,@(cdr declaration)) else collect declaration) into declarations finally (multiple-value-bind (method-lambda method-args) (clos:make-method-lambda gf method args declarations `(progn ,car ,@cdr) environment) (if (eq documentation :unbound) (return (values method-lambda method-args)) (return (values `(lambda ,(cadr method-lambda) ,documentation ,@(cddr method-lambda)) method-args))))))) ;; Provide standard-instance-access and funcallable-standard-instance-access (declaim (inline standard-instance-access (setf standard-instance-access))) (defun standard-instance-access (instance location) (clos::fast-standard-instance-access instance location)) (defun (setf standard-instance-access) (new-value instance location) (setf (clos::fast-standard-instance-access instance location) new-value)) (declaim (inline funcallable-instance-access)) (defun funcallable-instance-access (instance location &rest args) (declare (dynamic-extent args)) (let* ((class (class-of instance)) (slot (find location (class-slots class) :key #'slot-definition-location))) (if slot (apply #'clos::funcallable-instance-access instance (slot-definition-name slot) args) (error "There is no slot with location ~S for instance ~S." location instance)))) (defun funcallable-standard-instance-access (instance location) (funcallable-instance-access instance location)) (defun (setf funcallable-standard-instance-access) (new-value instance location) (funcallable-instance-access instance location new-value)) (eval-when (:compile-toplevel :load-toplevel :execute) (pushnew :closer-mop *features*)) cl-closer-mop-0.6.orig/closer-clozure.lisp0000644000175000017500000002023611317133033021063 0ustar pvaneyndpvaneynd(in-package :closer-mop) (defclass standard-class (cl:standard-class) ()) (define-validate-superclass-method standard-class cl:standard-class) (cl:defmethod reinitialize-instance :after ((class standard-class) &key) (finalize-inheritance class)) ;;; New generic functions. ;; Store the method function somewhere else, to circumvent ;; the native check for congruent lambda lists. (defparameter *stub-method-functions* (make-hash-table :test #'equal)) (defun get-stub-method-function (lambda-list) (or (gethash lambda-list *stub-method-functions*) (let ((ignore-list (loop for arg in lambda-list unless (member arg lambda-list-keywords) collect (etypecase arg (symbol arg) (cons (etypecase (car arg) (symbol (car arg)) (cons (assert (cdr arg)) (cadr arg)))))))) (setf (gethash lambda-list *stub-method-functions*) (compile nil `(lambda ,lambda-list (declare (ignore ,@ignore-list)) (error "This method function must not be called."))))))) (cl:defmethod initialize-instance :around ((method standard-method) &rest initargs &key lambda-list function closer-patch) (if closer-patch (apply #'call-next-method method :real-function function :function (get-stub-method-function lambda-list) initargs) (apply #'call-next-method method :real-function function initargs))) ;; Adapt argument-precedence-order whenever the lambda list changes. (cl:defmethod reinitialize-instance :around ((gf standard-generic-function) &rest initargs &key (lambda-list '() lambda-list-p) (argument-precedence-order '() argument-precedence-order-p)) (declare (dynamic-extent initargs) (ignore argument-precedence-order)) (if (and lambda-list-p (not argument-precedence-order-p)) (apply #'call-next-method gf :argument-precedence-order (required-args lambda-list) initargs) (call-next-method))) ;; Ensure that the discriminating function is computed and installed ;; at the moments in time as stated in the CLOS MOP specification. (cl:defmethod add-method :after ((gf standard-generic-function) method) (declare (ignore method)) (set-funcallable-instance-function gf (compute-discriminating-function gf))) (cl:defmethod remove-method :after ((gf standard-generic-function) method) (declare (ignore method)) (set-funcallable-instance-function gf (compute-discriminating-function gf))) (cl:defmethod initialize-instance :after ((gf standard-generic-function) &key) (set-funcallable-instance-function gf (compute-discriminating-function gf))) (cl:defmethod reinitialize-instance :after ((gf standard-generic-function) &key) (set-funcallable-instance-function gf (compute-discriminating-function gf))) ;; Define compute-effective-method correctly. (cl:defmethod compute-effective-method ((gf standard-generic-function) (combination ccl:standard-method-combination) methods) (declare (optimize (speed 3) (space 0) (compilation-speed 0))) (loop for method in methods for qualifiers = (method-qualifiers method) if (equal qualifiers '()) collect method into primary else if (equal qualifiers '(:before)) collect method into before else if (equal qualifiers '(:after)) collect method into after else if (equal qualifiers '(:around)) collect method into around else do (invalid-method-error method "Invalid method qualifiers ~S." qualifiers) finally (unless primary (method-combination-error "No primary method.")) (let ((form (if (or before after (rest primary)) `(multiple-value-prog1 (progn ,@(loop for method in before collect `(call-method ,method)) (call-method ,(first primary) ,(rest primary))) ,@(loop for method in (reverse after) collect `(call-method ,method))) `(call-method ,(first primary))))) (return (if around `(call-method ,(first around) (,@(rest around) (make-method ,form))) form))))) (cl:defmethod compute-effective-method ((gf standard-generic-function) (combination ccl:short-method-combination) methods) (declare (optimize (speed 3) (space 0) (compilation-speed 0))) (loop with primary-qualifiers = (list (ccl::method-combination-name combination)) for method in methods for qualifiers in (method-qualifiers method) if (equal qualifiers primary-qualifiers) collect method into primary else if (equal qualifiers '(:around)) collect method into around else do (invalid-method-error method "Invalid method qualifiers ~S." qualifiers) finally (unless primary (method-combination-error "No primary method.")) (when (eq (car (ccl::method-combination-options combination)) :most-specific-last) (setq primary (nreverse primary))) (let ((form (if (and (ccl::method-combination-identity-with-one-argument combination) (null (rest primary))) `(call-method ,(first primary)) `(,(ccl::method-combination-operator combination) ,@(loop for method in primary collect `(call-method ,method)))))) (return (if around `(call-method ,(first around) (,@(rest around) (make-method ,form))) form))))) (cl:defmethod compute-effective-method ((gf standard-generic-function) (combination ccl:long-method-combination) methods) (declare (optimize (speed 3) (space 0) (compilation-speed 0))) (destructuring-bind ((args-var . gf-name) . expander) (ccl::method-combination-expander combination) (declare (ignore args-var gf-name)) (funcall expander gf methods (ccl::method-combination-options combination)))) ;; "Native" make-method-lambda. (cl:defmethod make-method-lambda ((gf generic-function) (method method) lambda-expression environment) (declare (ignore environment) (optimize (speed 3) (space 0) (compilation-speed 0))) (let ((methvar (gensym))) (values `(lambda (ccl::&method ,methvar ,@(cadr lambda-expression)) (flet ((call-next-method (&rest args) (declare (dynamic-extent args)) (if args (apply #'ccl::%call-next-method-with-args ,methvar args) (ccl::%call-next-method ,methvar))) (next-method-p () (ccl::%next-method-p ,methvar))) (declare (inline call-next-method next-method-p)) ,@(cddr lambda-expression))) (let ((documentation (parse-method-body (cddr lambda-expression) lambda-expression))) (when documentation (list :documentation documentation)))))) ;; "Native" compute-discriminating-function. (cl:defmethod compute-discriminating-function ((gf generic-function)) (let ((non-dt-dcode (ccl::non-dt-dcode-function gf))) (if non-dt-dcode non-dt-dcode (let* ((std-dfun (ccl::%gf-dcode gf)) (dt (ccl::%gf-dispatch-table gf)) (proto (cdr (assoc std-dfun ccl::dcode-proto-alist)))) (if (or (eq proto #'ccl::gag-one-arg) (eq proto #'ccl::gag-two-arg)) (lambda (&rest args) (declare (dynamic-extent args)) (apply std-dfun dt args)) (lambda (&rest args) (declare (dynamic-extent args)) (funcall std-dfun dt args))))))) ;; The following ensures that slot definitions have a documentation. (cl:defmethod documentation ((slot slot-definition) (type (eql 't))) (ccl:slot-definition-documentation slot)) (eval-when (:compile-toplevel :load-toplevel :execute) (pushnew :closer-mop *features*)) cl-closer-mop-0.6.orig/closer-ecl.lisp0000644000175000017500000003355611317133033020154 0ustar pvaneyndpvaneynd(in-package :closer-mop) (defmacro removef (place item) `(setf ,place (remove ,item ,place))) (defun extract-lambda-list (lambda-list) (loop for (arg . rest) on lambda-list for keyp = (member arg lambda-list-keywords) until keyp if (consp arg) collect (car arg) into args else collect arg into args finally (return (if keyp (nconc args (cons arg rest)) args)))) (defun extract-specializer-names (lambda-list) (loop for arg in lambda-list until (member arg lambda-list-keywords) if (consp arg) collect (cadr arg) else collect 't)) (cl:defgeneric generic-function-method-class (object) (:method ((gf generic-function)) (clos:generic-function-method-class gf))) (cl:defmethod compute-discriminating-function ((gf generic-function)) t) (cl:defmethod make-method-lambda ((gf generic-function) (method method) lambda-expression environment) (declare (ignore environment)) (destructuring-bind (lambda (&rest args) &body body) lambda-expression (declare (ignore args)) (assert (eq lambda 'lambda)) (values lambda-expression (let ((documentation (parse-method-body body lambda-expression))) (when documentation (list 'documentation documentation)))))) (cl:defmethod compute-effective-method-function ((gf standard-generic-function) effective-method options) (declare (optimize (speed 3) (space 0) (compilation-speed 0))) (when options (cerror "Ignore these options." "This version of compute-effective-method-function does not support method combination options: ~S" options)) (if (only-standard-methods gf) effective-method (lambda (&rest args) (declare (dynamic-extent args)) (funcall effective-method args nil)))) (cl:defgeneric find-method-combination (generic-function type options) (:method ((gf generic-function) type options) (cons type options))) (defclass standard-class (cl:standard-class) ((direct-methods :initform '() :reader specializer-direct-methods))) (defun optimize-slot-access-p (class) (flet ((applicablep (specializer) (if (consp specializer) (eql class (eql-specializer-object specializer)) (subclassp (class-of class) specializer)))) (when (and (loop for method in (generic-function-methods #'slot-value-using-class) never (applicablep (first (method-specializers method)))) (loop for method in (generic-function-methods #'(setf slot-value-using-class)) never (applicablep (second (method-specializers method))))) '(t)))) (cl:defmethod initialize-instance :around ((class standard-class) &rest initargs) (declare (dynamic-extent initargs)) (apply #'call-next-method class :optimize-slot-access (optimize-slot-access-p class) initargs)) (cl:defmethod reinitialize-instance :around ((class standard-class) &rest initargs) (declare (dynamic-extent initargs)) (apply #'call-next-method class :optimize-slot-access (optimize-slot-access-p class) initargs)) (cl:defmethod initialize-instance :around ((class funcallable-standard-class) &rest initargs) (declare (dynamic-extent initargs)) (apply #'call-next-method class :optimize-slot-access (optimize-slot-access-p class) initargs)) (cl:defmethod reinitialize-instance :around ((class funcallable-standard-class) &rest initargs) (declare (dynamic-extent initargs)) (apply #'call-next-method class :optimize-slot-access (optimize-slot-access-p class) initargs)) (cl:defmethod initialize-instance :before ((class standard-class) &key direct-superclasses) (assert (loop for superclass in direct-superclasses always (validate-superclass class superclass)))) (cl:defmethod reinitialize-instance :before ((class standard-class) &key (direct-superclasses '() direct-superclasses-p)) (when direct-superclasses-p (assert (loop for superclass in direct-superclasses always (validate-superclass class superclass))) (loop for superclass in (class-direct-superclasses class) unless (member superclass direct-superclasses) do (remove-direct-subclass superclass class)))) (cl:defmethod initialize-instance :before ((class funcallable-standard-class) &key direct-superclasses) (assert (loop for superclass in direct-superclasses always (validate-superclass class superclass)))) (cl:defmethod initialize-instance :before ((class funcallable-standard-class) &key direct-superclasses) (assert (loop for superclass in direct-superclasses always (validate-superclass class superclass)))) (cl:defmethod (setf class-name) (new-value (class standard-class)) (reinitialize-instance class :name new-value) new-value) (cl:defmethod (setf generic-function-name) (new-value (gf standard-generic-function)) (reinitialize-instance gf :name new-value) new-value) (defvar *direct-methods-for-built-in-classes* (make-hash-table :test #'eq)) (cl:defgeneric add-direct-method (specializer method) (:method ((specializer class) (method method))) (:method ((specializer built-in-class) (method method)) (pushnew method (gethash specializer *direct-methods-for-built-in-classes*))) (:method ((specializer standard-class) (method method)) (pushnew method (slot-value specializer 'direct-methods))) (:method ((specializer funcallable-standard-class) (method method)) (pushnew method (slot-value specializer 'direct-methods)))) (cl:defgeneric remove-direct-method (specializer method) (:method ((specializer class) (method method))) (:method ((specializer built-in-class) (method method)) (removef (gethash specializer *direct-methods-for-built-in-classes*) method)) (:method ((specializer standard-class) (method method)) (removef (slot-value specializer 'direct-methods) method)) (:method ((specializer funcallable-standard-class) (method method)) (removef (slot-value specializer 'direct-methods) method))) (defvar *dependents* (make-hash-table :test #'eq)) (cl:defgeneric add-dependent (metaobject dependent) (:method ((metaobject standard-class) dependent) (pushnew dependent (gethash metaobject *dependents*))) (:method ((metaobject funcallable-standard-class) dependent) (pushnew dependent (gethash metaobject *dependents*))) (:method ((metaobject standard-generic-function) dependent) (pushnew dependent (gethash metaobject *dependents*)))) (cl:defgeneric remove-dependent (metaobject dependent) (:method ((metaobject standard-class) dependent) (setf (gethash metaobject *dependents*) (delete dependent (gethash metaobject *dependents*)))) (:method ((metaobject funcallable-standard-class) dependent) (setf (gethash metaobject *dependents*) (delete dependent (gethash metaobject *dependents*)))) (:method ((metaobject standard-generic-function) dependent) (setf (gethash metaobject *dependents*) (delete dependent (gethash metaobject *dependents*))))) (cl:defgeneric map-dependents (metaobject function) (:method ((metaobject standard-class) function) (mapc function (gethash metaobject *dependents*))) (:method ((metaobject funcallable-standard-class) function) (mapc function (gethash metaobject *dependents*))) (:method ((metaobject standard-generic-function) function) (mapc function (gethash metaobject *dependents*)))) (cl:defgeneric update-dependent (metaobject dependent &rest initargs)) (cl:defmethod reinitialize-instance :after ((metaobject standard-class) &rest initargs) (declare (dynamic-extent initargs)) (map-dependents metaobject (lambda (dep) (apply #'update-dependent metaobject dep initargs)))) (cl:defmethod reinitialize-instance :after ((metaobject funcallable-standard-class) &rest initargs) (declare (dynamic-extent initargs)) (map-dependents metaobject (lambda (dep) (apply #'update-dependent metaobject dep initargs)))) (cl:defmethod initialize-instance :after ((gf standard-generic-function) &rest initargs) (declare (ignore initargs)) (set-funcallable-instance-function gf (compute-discriminating-function gf))) (cl:defmethod ensure-generic-function-using-class :around ((gf null) name &rest initargs) (declare (ignore name initargs)) (let ((new-gf (call-next-method))) (if (typep new-gf 'standard-generic-function) (set-funcallable-instance-function new-gf (compute-discriminating-function new-gf)) new-gf))) (cl:defmethod reinitialize-instance :after ((gf standard-generic-function) &rest initargs) (declare (dynamic-extent initargs)) (set-funcallable-instance-function gf (compute-discriminating-function gf)) (map-dependents gf (lambda (dep) (apply #'update-dependent gf dep initargs)))) (cl:defgeneric remove-method (gf method) (:method ((gf generic-function) (method method)) (cl:remove-method gf method))) (cl:defmethod remove-method :after ((gf standard-generic-function) (method method)) (set-funcallable-instance-function gf (compute-discriminating-function gf)) (loop for specializer in (method-specializers method) if (consp specializer) do (remove-direct-method (intern-eql-specializer* (eql-specializer-object specializer)) method) else do (remove-direct-method specializer method)) (map-dependents gf (lambda (dep) (update-dependent gf dep 'remove-method method)))) (cl:defgeneric find-method (gf qualifiers specializers &optional errorp) (:method ((gf generic-function) qualifiers specializers &optional (errorp t)) (cl:find-method gf qualifiers specializers errorp))) (cl:defmethod add-method :before ((gf standard-generic-function) (method method)) (let ((other-gf (method-generic-function method))) (unless (or (null other-gf) (eq other-gf gf)) (error "The method ~S belongs to the generic function ~S and cannot be added to ~S." method other-gf gf))) (let ((old-method (find-method gf (method-qualifiers method) (method-specializers method) nil))) (when old-method (remove-method gf old-method)))) (cl:defmethod add-method :after ((gf standard-generic-function) (method method)) (set-funcallable-instance-function gf (compute-discriminating-function gf)) (loop for specializer in (method-specializers method) if (consp specializer) do (add-direct-method (intern-eql-specializer* (eql-specializer-object specializer)) method) else do (add-direct-method specializer method)) (map-dependents gf (lambda (dep) (update-dependent gf dep 'add-method method)))) (defun eql-specializer-p (thing) (and (consp thing) (eq (car thing) 'eql) (null (cddr thing)))) (deftype eql-specializer () '(or eql-specializer* (satisfies eql-specializer-p))) (cl:defgeneric eql-specializer-object (eql-specializer) (:method ((cons cons)) (if (eql-specializer-p cons) (cadr cons) (error "~S is not an eql-specializer." cons)))) (defun intern-eql-specializer (object) `(eql ,object)) (cl:defmethod specializer-direct-methods ((cons cons)) (specializer-direct-methods (eql-specializer-object cons))) (defclass eql-specializer* () ((obj :reader eql-specializer-object :initarg eso :initform (error "Use intern-eql-specializer to create eql-specializers.")) (direct-methods :reader specializer-direct-methods :accessor es-direct-methods :initform ()))) (defvar *eql-specializers* (make-hash-table)) #+threads (defvar *eql-specializers-lock* (mp:make-lock :name 'eql-specializers)) (defmacro with-eql-specializers-lock (&body body) #+threads `(mp:with-lock (*eql-specializers-lock*) ,@body) #-threads `(progn ,@body)) (defun intern-eql-specializer* (object) (or #+threads (gethash object *eql-specializers*) (with-eql-specializers-lock (or (gethash object *eql-specializers*) (setf (gethash object *eql-specializers*) (make-instance 'eql-specializer* 'eso object)))))) (cl:defmethod add-direct-method ((specializer eql-specializer*) (method method)) (pushnew method (es-direct-methods specializer))) (cl:defmethod remove-direct-method ((specializer eql-specializer*) (method method)) (removef (es-direct-methods specializer) method)) (cl:defgeneric specializer-direct-generic-functions (specializer) (:method ((class class)) (remove-duplicates (mapcar #'method-generic-function (specializer-direct-methods class)))) (:method ((eql-specializer eql-specializer*)) (remove-duplicates (mapcar #'method-generic-function (specializer-direct-methods eql-specializer)))) (:method ((cons cons)) (specializer-direct-generic-functions (intern-eql-specializer* (eql-specializer-object cons))))) (cl:defgeneric validate-superclass (class superclass) (:method (class superclass) (or (eq superclass (find-class 't)) (typep superclass (find-class 'forward-referenced-class)) (eq (class-of class) (class-of superclass)) (let ((compatible-classes (list (find-class 'cl:standard-class) (find-class 'standard-class) (find-class 'clos:funcallable-standard-class) (find-class 'funcallable-standard-class)))) (and (member (class-of class) compatible-classes) (member (class-of superclass) compatible-classes)))))) (define-validate-superclass-method standard-class cl:standard-class) (define-validate-superclass-method funcallable-standard-class clos:funcallable-standard-class) (eval-when (:compile-toplevel :load-toplevel :execute) (pushnew :closer-mop *features*)) cl-closer-mop-0.6.orig/closer-clisp.lisp0000644000175000017500000000016511317133033020511 0ustar pvaneyndpvaneynd(in-package :closer-mop) (eval-when (:compile-toplevel :load-toplevel :execute) (pushnew :closer-mop *features*)) cl-closer-mop-0.6.orig/closer-mop-packages.lisp0000644000175000017500000002003111317133033021740 0ustar pvaneyndpvaneynd(in-package :cl-user) (defpackage #:closer-mop (:use #:common-lisp #+lispworks #:lispworks) (:nicknames #:c2mop) #+(or allegro clozure ecl lispworks mcl) (:shadow #:standard-class) #+(or allegro clisp clozure ecl lispworks sbcl) (:shadow #:defgeneric #:defmethod #:standard-generic-function) #+ecl (:shadow #:compute-applicable-methods #:find-method #:remove-method) #+clozure (:shadow standard-method) #+(or cmu mcl) (:shadow #:typep subtypep) #+lispworks5 (:import-from #:system #:with-hash-table-locked) #-(or clisp scl) (:import-from #+allegro #:excl #+clozure #:ccl #+cmu #:pcl #+ecl #:clos #+lispworks #:clos #+mcl #:ccl #+sbcl #:sb-pcl #:classp) (:import-from #+allegro #:mop #+clisp #:clos #+clozure #:ccl #+cmu #:clos-mop #+ecl #:clos #+lispworks #:clos #+mcl #:ccl #+sbcl #:sb-mop #+scl #:clos #:direct-slot-definition #:effective-slot-definition #-lispworks #:eql-specializer #:forward-referenced-class #-(or ecl lispworks) #:funcallable-standard-class #-lispworks4 #:funcallable-standard-object #:metaobject #:slot-definition #-(or lispworks scl) #:specializer #:standard-accessor-method #:standard-direct-slot-definition #:standard-effective-slot-definition #:standard-reader-method #:standard-slot-definition #:standard-writer-method #-lispworks4.3 #:accessor-method-slot-definition #-(or ecl scl) #:add-dependent #-(or ecl scl) #:add-direct-method #:add-direct-subclass #-scl #:class-default-initargs #-scl #:class-direct-default-initargs #:class-direct-slots #:class-direct-subclasses #:class-direct-superclasses #:class-finalized-p #:class-precedence-list #:class-prototype #:class-slots #-(or clozure ecl lispworks mcl) #:compute-applicable-methods-using-classes #:compute-class-precedence-list #-lispworks #:compute-default-initargs #-(or clozure ecl) #:compute-discriminating-function #-(or clozure ecl scl) #:compute-effective-method #:compute-effective-slot-definition #:compute-slots #:direct-slot-definition-class #:effective-slot-definition-class #:ensure-class #:ensure-class-using-class #:ensure-generic-function-using-class #-lispworks #:eql-specializer-object #-ecl #:extract-lambda-list #-ecl #:extract-specializer-names #:finalize-inheritance #-(or ecl lispworks) #:find-method-combination #-(or lispworks scl) #:funcallable-standard-instance-access #-allegro #:generic-function-argument-precedence-order #-ecl #:generic-function-declarations #:generic-function-lambda-list #-ecl #:generic-function-method-class #:generic-function-method-combination #:generic-function-methods #:generic-function-name #-lispworks #:intern-eql-specializer #-(or allegro clisp clozure ecl lispworks mcl scl) #:make-method-lambda #-(or ecl scl) #:map-dependents #-clozure #:method-function #:method-generic-function #:method-lambda-list #:method-specializers #-lispworks4.3 #:reader-method-class #-(or ecl scl) #:remove-dependent #-(or ecl scl) #:remove-direct-method #:remove-direct-subclass #:set-funcallable-instance-function #:slot-boundp-using-class #:slot-definition-allocation #:slot-definition-initargs #:slot-definition-initform #:slot-definition-initfunction #:slot-definition-location #:slot-definition-name #:slot-definition-readers #:slot-definition-writers #:slot-definition-type #:slot-makunbound-using-class #:slot-value-using-class #-lispworks #:specializer-direct-generic-functions #:specializer-direct-methods #-lispworks #:standard-instance-access #-(or ecl scl) #:update-dependent #-ecl #:validate-superclass #-lispworks4.3 #:writer-method-class) (:export #:built-in-class #:class #:direct-slot-definition #:effective-slot-definition #:eql-specializer #+(or ecl lispworks) #:eql-specializer* #:forward-referenced-class #:funcallable-standard-class #:funcallable-standard-object #:generic-function #:metaobject #:method #:method-combination #:slot-definition #:specializer #:standard-accessor-method #:standard-class #:standard-generic-function #:standard-direct-slot-definition #:standard-effective-slot-definition #:standard-method #:standard-object #:standard-reader-method #:standard-slot-definition #:standard-writer-method #:defclass #:defgeneric #:define-method-combination #:defmethod #:classp #:ensure-finalized #:ensure-method #:fix-slot-initargs #:required-args #:subclassp #:accessor-method-slot-definition #:add-dependent #:add-direct-method #:add-direct-subclass #:class-default-initargs #:class-direct-default-initargs #:class-direct-slots #:class-direct-subclasses #:class-direct-superclasses #:class-finalized-p #:class-precedence-list #:class-prototype #:class-slots #:compute-applicable-methods-using-classes #:compute-class-precedence-list #:compute-default-initargs #:compute-discriminating-function #:compute-effective-method #:compute-effective-method-function #:compute-effective-slot-definition #:compute-slots #:direct-slot-definition-class #:effective-slot-definition-class #:ensure-class #:ensure-class-using-class #:ensure-generic-function #:ensure-generic-function-using-class #:eql-specializer-object #:extract-lambda-list #:extract-specializer-names #:finalize-inheritance #:find-method-combination #:funcallable-standard-instance-access #:generic-function-argument-precedence-order #:generic-function-declarations #:generic-function-lambda-list #:generic-function-method-class #:generic-function-method-combination #:generic-function-methods #:generic-function-name #:intern-eql-specializer #+(or ecl lispworks) #:intern-eql-specializer* #:make-method-lambda #:map-dependents #:method-function #:method-generic-function #:method-lambda-list #:method-specializers #:reader-method-class #:remove-dependent #:remove-direct-method #:remove-direct-subclass #:set-funcallable-instance-function #:slot-boundp-using-class #:slot-definition-allocation #:slot-definition-initargs #:slot-definition-initform #:slot-definition-initfunction #:slot-definition-location #:slot-definition-name #:slot-definition-readers #:slot-definition-writers #:slot-definition-type #:slot-makunbound-using-class #:slot-value-using-class #:specializer-direct-generic-functions #:specializer-direct-methods #:standard-instance-access #:subtypep #:typep #:update-dependent #:validate-superclass #:writer-method-class #:warn-on-defmethod-without-generic-function)) (macrolet ((define-closer-common-lisp-package () (loop with symbols = (nunion (loop for sym being the external-symbols of :common-lisp if (find-symbol (symbol-name sym) :c2mop) collect it else collect sym) (loop for sym being the external-symbols of :c2mop collect sym)) with map = '() for symbol in symbols do (push (symbol-name symbol) (getf map (symbol-package symbol))) finally (return `(defpackage #:closer-common-lisp (:nicknames #:c2cl) (:use) ,@(loop for (package symbols) on map by #'cddr collect `(:import-from ,(package-name package) ,@symbols)) (:export ,@(mapcar #'symbol-name symbols))))))) (define-closer-common-lisp-package)) (defpackage #:closer-common-lisp-user (:nicknames #:c2cl-user) (:use #:closer-common-lisp)) cl-closer-mop-0.6.orig/closer-scl.lisp0000644000175000017500000000475611317133033020172 0ustar pvaneyndpvaneynd(in-package :closer-mop) (defgeneric add-direct-method (specializer method) (:method ((specializer standard-object) (method method)))) (defgeneric remove-direct-method (specializer method) (:method ((specializer standard-object) (method method)))) (defvar *dependents* (make-hash-table :test #'eq)) (defgeneric add-dependent (metaobject dependent) (:method ((metaobject standard-class) dependent) (pushnew dependent (gethash metaobject *dependents*))) (:method ((metaobject funcallable-standard-class) dependent) (pushnew dependent (gethash metaobject *dependents*))) (:method ((metaobject standard-generic-function) dependent) (pushnew dependent (gethash metaobject *dependents*)))) (defgeneric remove-dependent (metaobject dependent) (:method ((metaobject standard-class) dependent) (setf (gethash metaobject *dependents*) (delete metaobject (gethash metaobject *dependents*)))) (:method ((metaobject funcallable-standard-class) dependent) (setf (gethash metaobject *dependents*) (delete metaobject (gethash metaobject *dependents*)))) (:method ((metaobject standard-generic-function) dependent) (setf (gethash metaobject *dependents*) (delete metaobject (gethash metaobject *dependents*))))) (defgeneric map-dependents (metaobject function) (:method ((metaobject standard-class) function) (mapc function (gethash metaobject *dependents*))) (:method ((metaobject funcallable-standard-class) function) (mapc function (gethash metaobject *dependents*))) (:method ((metaobject standard-generic-function) function) (mapc function (gethash metaobject *dependents*)))) (defgeneric update-dependent (metaobject dependent &rest initargs)) (defmethod reinitialize-instance :after ((metaobject metaobject) &rest initargs) (declare (dynamic-extent initargs)) (map-dependents metaobject (lambda (dep) (apply #'update-dependent metaobject dep initargs)))) (defmethod add-method :after ((gf standard-generic-function) method) (loop for specializer in (method-specializers method) do (add-direct-method specializer method)) (map-dependents gf (lambda (dep) (update-dependent gf dep 'add-method method)))) (defmethod remove-method :after ((gf standard-generic-function) method) (loop for specializer in (method-specializers method) do (remove-direct-method specializer method)) (map-dependents gf (lambda (dep) (update-dependent gf dep 'remove-method method)))) (eval-when (:compile-toplevel :load-toplevel :execute) (pushnew :closer-mop *features*)) cl-closer-mop-0.6.orig/closer-mop-system.cl0000644000175000017500000000241311317133033021141 0ustar pvaneyndpvaneynd(in-package :cl-user) #| :name "Closer to MOP" :author "Pascal Costanza" :version "0.6" :licence " Copyright (c) 2005 - 2009 Pascal Costanza Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the \"Software\"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. " |# (defsystem :closer-mop () (:serial "closer-mop-packages" "closer-mop-shared" "closer-allegro")) cl-closer-mop-0.6.orig/release-notes.txt0000644000175000017500000001026711317133033020534 0ustar pvaneyndpvaneyndCloser to MOP Release Note v0.0 initial release v0.1 - separated single implementation into several ones, one for each MOP implementation / implementation family, in order to improve maintainability - added support for LispWorks 4.4 - removed extra method options from the LispWorks defmethod - it's a useful feature, but doesn't belong here - the automatically generated slot accessor methods in LispWorks closed over the wrong slot names. fixed. (obsolete because of the next issue) - In some cases, LispWorks deoptimizes slot access and reverts to the slot-value-using-class, etc., functions. This rendered the previously taken approach for fixing that protocol useless. Now, we have a much simpler fix. (Thanks to Jeff Caldwell.) Unfortunately, now some of the features that were previously fixed are missing again (correct initialization of accessor methods, accessor-method-slot-definition, reader-method-class and writer-method-class). Fortunately, LispWorks has already fixed those in 4.4, so this is no problem anymore in the long run. v0.2 - The trick for reinitialization of generic-function-name or class-name in allegro, pcl, lispworks and mcl didn't work and had to be dropped. - In clisp, defgeneric does call ensure-generic-function-using-class. This wasn't detected before due to a bug in mop-feature-tests. (Thanks to Bruno Haible.) - Added the utility function ensure-method for programmatically creating methods, supported on all platforms. - The defmethod macro for LispWorks didn't have an implicit block with the name of the generic function. Fixed. - LispWorks 4.3 is not supported anymore. The existing conditionalizations are still available, though, and will be retained as long as they don't stand in the way of anything else. - Since I have to override some symbols from the common-lisp package, I provide two utility packages closer-common-lisp and closer-common-lisp-user, similar to common-lisp and common-lisp-user but with all the MOP symbols added. The default packages additionally added by the various Common Lisp implementations are not added here. (I think that's cleaner.) - Handling of pseudo-anonymous classes in CMU CL and SBCL had a copy&paste bug: The name was changed again in reinitialize-instance. - TYPEP and SUBTYPEP don't work as expected in CMU CL and SBCL in conjunction with class metaobjects. Same for MCL, but for different reasons. So I have shadowed them and provide a new definition. (In CMU CL and SBCL, class metaobject are not considered types. In MCL, type information for class metaobjects is not available at some stages. Unfortunately, it doesn't seem to be possible to fix this with finalize-inheritance, so I have to revert to membership tests on the class precedence list.) - MCL also doesn't like anonymous classes. So I have added a fix for that. - I have incorrectly reported that MAKE-METHOD-LAMBDA is unreliable in CMU CL and SBCL. This was due to a bug in my test suite. However, it is required that the respective generic function and method metaobject classes and make-method-lambda definitions are part of the compilation environment when you want to use them. I have updated the respective sections in features.lisp and features.txt. - Switched to an MIT/BSD-style license. v0.3 - Now supports OpenMCL 1.0, LispWorks 4.4.6, SBCL 0.9.7 - 0.9.9, CMUCL 19C, Allegro 8.0, clisp 2.37 and 2.38. - STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are now compatible in SBCL. This required some changes in the PCL support. - Dropped the reports for LispWorks 4.3. - Allegro 6.2 is not supported anymore. The existing conditionalizations are still available, though, and will be retained as long as they don't stand in the way of anything else. - The incorrect specialization of slot-boundp-using-class and slot-makunbound-using-class on symbols instead of slot definition metaobjects in Allegro is fixed. - SBCL 0.9.7 has improved a lot wrt MOP compatibility. This required some changes in the PCL support. - The lack of extensible :allocation kinds in Allegro is fixed. (Covers 6.2, 7.0 and 8.0. Thanks to John Foderaro for giving me the important hint on how to solve this.) After version 0.3, there are no separate release notes anymore, but they will be generated automatically by darcs in the future.