X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=f33308552e9e29b8da8b3299686a67081edcacbe;hb=d771d9b799b609e7b75b799d2879b4fda1ba8fa7;hp=807b45b4950bab352de496296966b66f4d9e4a65;hpb=475c832b081651e66ad9446d4852c62086f5e740;p=sbcl.git diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 807b45b..f333085 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -23,22 +23,6 @@ (in-package "SB-PCL") -(defmethod shared-initialize :after ((slotd standard-slot-definition) - slot-names &key) - (declare (ignore slot-names)) - (with-slots (allocation class) - slotd - (setq allocation (if (eq allocation :class) class allocation)))) - -(defmethod shared-initialize :after ((slotd structure-slot-definition) - slot-names - &key (allocation :instance)) - (declare (ignore slot-names)) - (unless (eq allocation :instance) - (error "Structure slots must have :INSTANCE allocation."))) - -(defmethod inform-type-system-about-class ((class structure-class) (name t)) - nil) ;;; methods ;;; @@ -46,15 +30,15 @@ ;;; methods are immutable, methods cannot be reinitialized. The following ;;; properties of methods can be changed: ;;; METHOD-GENERIC-FUNCTION -;;; METHOD-FUNCTION ?? +;;; METHOD-FUNCTION ?? (defmethod method-function ((method standard-method)) (or (slot-value method 'function) (let ((fmf (slot-value method 'fast-function))) - (unless fmf ; The :BEFORE SHARED-INITIALIZE method prevents this. - (error "~S doesn't seem to have a METHOD-FUNCTION." method)) - (setf (slot-value method 'function) - (method-function-from-fast-function fmf))))) + (unless fmf ; The :BEFORE SHARED-INITIALIZE method prevents this. + (error "~S doesn't seem to have a METHOD-FUNCTION." method)) + (setf (slot-value method 'function) + (method-function-from-fast-function fmf))))) (defmethod accessor-method-class ((method standard-accessor-method)) (car (slot-value method 'specializers))) @@ -69,11 +53,29 @@ ;;; ;;; Methods are not reinitializable. -(defmethod reinitialize-instance ((method standard-method) &rest initargs) - (declare (ignore initargs)) - (error "An attempt was made to reinitialize the method ~S.~%~ - Method objects cannot be reinitialized." - method)) +(define-condition metaobject-initialization-violation + (reference-condition simple-condition) + ()) + +(macrolet ((def (name args control) + `(defmethod ,name ,args + (declare (ignore initargs)) + (error 'metaobject-initialization-violation + :format-control ,(format nil "~@<~A~@:>" control) + :format-arguments (list ',name) + :references (list '(:amop :initialization "Method")))))) + (def reinitialize-instance ((method method) &rest initargs) + "Method objects cannot be redefined by ~S.") + (def change-class ((method method) new &rest initargs) + "Method objects cannot be redefined by ~S.") + ;; FIXME: NEW being a subclass of METHOD. + (def update-instance-for-redefined-class ((method method) added discarded + plist &rest initargs) + "No behaviour specified for ~S on method objects.") + (def update-instance-for-different-class (old (new method) &rest initargs) + "No behaviour specified for ~S on method objects.") + (def update-instance-for-different-class ((old method) new &rest initargs) + "No behaviour specified for ~S on method objects.")) (defmethod legal-documentation-p ((object standard-method) x) (if (or (null x) (stringp x)) @@ -91,12 +93,12 @@ (defmethod legal-qualifiers-p ((object standard-method) x) (flet ((improper-list () - (return-from legal-qualifiers-p "Is not a proper list."))) + (return-from legal-qualifiers-p "Is not a proper list."))) (dolist-carefully (q x improper-list) (let ((ok (legal-qualifier-p object q))) - (unless (eq ok t) - (return-from legal-qualifiers-p - (format nil "Contains ~S which ~A" q ok))))) + (unless (eq ok t) + (return-from legal-qualifiers-p + (format nil "Contains ~S which ~A" q ok))))) t)) (defmethod legal-qualifier-p ((object standard-method) x) @@ -105,96 +107,93 @@ "is not a non-null atom")) (defmethod legal-slot-name-p ((object standard-method) x) - (cond ((not (symbolp x)) "is not a symbol and so cannot be bound") - ((keywordp x) "is a keyword and so cannot be bound") - ((memq x '(t nil)) "cannot be bound") - ((constantp x) "is a constant and so cannot be bound") - (t t))) + (cond ((not (symbolp x)) "is not a symbol") + (t t))) (defmethod legal-specializers-p ((object standard-method) x) (flet ((improper-list () - (return-from legal-specializers-p "Is not a proper list."))) + (return-from legal-specializers-p "Is not a proper list."))) (dolist-carefully (s x improper-list) (let ((ok (legal-specializer-p object s))) - (unless (eq ok t) - (return-from legal-specializers-p - (format nil "Contains ~S which ~A" s ok))))) + (unless (eq ok t) + (return-from legal-specializers-p + (format nil "Contains ~S which ~A" s ok))))) t)) (defvar *allow-experimental-specializers-p* nil) (defmethod legal-specializer-p ((object standard-method) x) (if (if *allow-experimental-specializers-p* - (specializerp x) - (or (classp x) - (eql-specializer-p x))) + (specializerp x) + (or (classp x) + (eql-specializer-p x))) t "is neither a class object nor an EQL specializer")) (defmethod shared-initialize :before ((method standard-method) - slot-names - &key qualifiers - lambda-list - specializers - function - fast-function - documentation) + slot-names + &key qualifiers + lambda-list + specializers + function + fast-function + documentation) (declare (ignore slot-names)) (flet ((lose (initarg value string) - (error "when initializing the method ~S:~%~ - The ~S initialization argument was: ~S.~%~ - which ~A." - method initarg value string))) + (error "when initializing the method ~S:~%~ + The ~S initialization argument was: ~S.~%~ + which ~A." + method initarg value string))) (let ((check-qualifiers (legal-qualifiers-p method qualifiers)) - (check-lambda-list (legal-lambda-list-p method lambda-list)) - (check-specializers (legal-specializers-p method specializers)) - (check-function (legal-method-function-p method - (or function - fast-function))) - (check-documentation (legal-documentation-p method documentation))) + (check-lambda-list (legal-lambda-list-p method lambda-list)) + (check-specializers (legal-specializers-p method specializers)) + (check-fun (legal-method-function-p method + (or function + fast-function))) + (check-documentation (legal-documentation-p method documentation))) (unless (eq check-qualifiers t) - (lose :qualifiers qualifiers check-qualifiers)) + (lose :qualifiers qualifiers check-qualifiers)) (unless (eq check-lambda-list t) - (lose :lambda-list lambda-list check-lambda-list)) + (lose :lambda-list lambda-list check-lambda-list)) (unless (eq check-specializers t) - (lose :specializers specializers check-specializers)) - (unless (eq check-function t) - (lose :function function check-function)) + (lose :specializers specializers check-specializers)) + (unless (eq check-fun t) + (lose :function function check-fun)) (unless (eq check-documentation t) - (lose :documentation documentation check-documentation))))) + (lose :documentation documentation check-documentation))))) (defmethod shared-initialize :before ((method standard-accessor-method) - slot-names - &key slot-name slot-definition) + slot-names + &key slot-name slot-definition) (declare (ignore slot-names)) (unless slot-definition (let ((legalp (legal-slot-name-p method slot-name))) ;; FIXME: nasty convention; should be renamed to ILLEGAL-SLOT-NAME-P and ;; ILLEGALP, and the convention redone to be less twisty (unless (eq legalp t) - (error "The value of the :SLOT-NAME initarg ~A." legalp))))) + (error "The value of the :SLOT-NAME initarg ~A." legalp))))) (defmethod shared-initialize :after ((method standard-method) slot-names - &rest initargs - &key qualifiers method-spec plist) + &rest initargs + &key qualifiers method-spec plist) (declare (ignore slot-names method-spec plist)) (initialize-method-function initargs nil method) (setf (plist-value method 'qualifiers) qualifiers) #+ignore (setf (slot-value method 'closure-generator) - (method-function-closure-generator (slot-value method 'function)))) + (method-function-closure-generator (slot-value method 'function)))) (defmethod shared-initialize :after ((method standard-accessor-method) - slot-names - &key) + slot-names + &key) (declare (ignore slot-names)) (with-slots (slot-name slot-definition) method (unless slot-definition (let ((class (accessor-method-class method))) - (when (slot-class-p class) - (setq slot-definition (find slot-name (class-direct-slots class) - :key #'slot-definition-name))))) + (when (slot-class-p class) + (setq slot-definition (find slot-name (class-direct-slots class) + :key #'slot-definition-name))))) (when (and slot-definition (null slot-name)) (setq slot-name (slot-definition-name slot-definition))))) @@ -207,74 +206,74 @@ (find-class 'standard-generic-function)) (defmethod shared-initialize :before - ((generic-function standard-generic-function) - slot-names - &key (name nil namep) - (lambda-list () lambda-list-p) - argument-precedence-order - declarations - documentation - (method-class nil method-class-supplied-p) - (method-combination nil method-combination-supplied-p)) + ((generic-function standard-generic-function) + slot-names + &key (name nil namep) + (lambda-list () lambda-list-p) + argument-precedence-order + declarations + documentation + (method-class nil method-class-supplied-p) + (method-combination nil method-combination-supplied-p)) (declare (ignore slot-names - declarations argument-precedence-order documentation - lambda-list lambda-list-p)) + declarations argument-precedence-order documentation + lambda-list lambda-list-p)) (when namep - (set-function-name generic-function name)) + (set-fun-name generic-function name)) (flet ((initarg-error (initarg value string) - (error "when initializing the generic function ~S:~%~ - The ~S initialization argument was: ~A.~%~ - It must be ~A." - generic-function initarg value string))) + (error "when initializing the generic function ~S:~%~ + The ~S initialization argument was: ~A.~%~ + It must be ~A." + generic-function initarg value string))) (cond (method-class-supplied-p - (when (symbolp method-class) - (setq method-class (find-class method-class))) - (unless (and (classp method-class) - (*subtypep (class-eq-specializer method-class) - *the-class-method*)) - (initarg-error :method-class - method-class - "a subclass of the class METHOD")) - (setf (slot-value generic-function 'method-class) method-class)) - ((slot-boundp generic-function 'method-class)) - (t - (initarg-error :method-class - "not supplied" - "a subclass of the class METHOD"))) + (when (symbolp method-class) + (setq method-class (find-class method-class))) + (unless (and (classp method-class) + (*subtypep (class-eq-specializer method-class) + *the-class-method*)) + (initarg-error :method-class + method-class + "a subclass of the class METHOD")) + (setf (slot-value generic-function 'method-class) method-class)) + ((slot-boundp generic-function 'method-class)) + (t + (initarg-error :method-class + "not supplied" + "a subclass of the class METHOD"))) (cond (method-combination-supplied-p - (unless (method-combination-p method-combination) - (initarg-error :method-combination - method-combination - "a method combination object"))) - ((slot-boundp generic-function 'method-combination)) - (t - (initarg-error :method-combination - "not supplied" - "a method combination object"))))) + (unless (method-combination-p method-combination) + (initarg-error :method-combination + method-combination + "a method combination object"))) + ((slot-boundp generic-function 'method-combination)) + (t + (initarg-error :method-combination + "not supplied" + "a method combination object"))))) #|| (defmethod reinitialize-instance ((generic-function standard-generic-function) - &rest initargs - &key name - lambda-list - argument-precedence-order - declarations - documentation - method-class - method-combination) + &rest initargs + &key name + lambda-list + argument-precedence-order + declarations + documentation + method-class + method-combination) (declare (ignore documentation declarations argument-precedence-order - lambda-list name method-class method-combination)) + lambda-list name method-class method-combination)) (macrolet ((add-initarg (check name slot-name) - `(unless ,check - (push (slot-value generic-function ,slot-name) initargs) - (push ,name initargs)))) + `(unless ,check + (push (slot-value generic-function ,slot-name) initargs) + (push ,name initargs)))) ; (add-initarg name :name 'name) ; (add-initarg lambda-list :lambda-list 'lambda-list) ; (add-initarg argument-precedence-order -; :argument-precedence-order -; 'argument-precedence-order) +; :argument-precedence-order +; 'argument-precedence-order) ; (add-initarg declarations :declarations 'declarations) ; (add-initarg documentation :documentation 'documentation) ; (add-initarg method-class :method-class 'method-class) @@ -282,72 +281,83 @@ (apply #'call-next-method generic-function initargs))) ||# -;;; These three are scheduled for demolition. - -(defmethod remove-named-method (generic-function-name argument-specifiers - &optional extra) - (let ((generic-function ()) - (method ())) - (cond ((or (null (fboundp generic-function-name)) - (not (generic-function-p - (setq generic-function - (name-get-fdefinition generic-function-name))))) - (error "~S does not name a generic function." - generic-function-name)) - ((null (setq method (get-method generic-function - extra - (parse-specializers - argument-specifiers) - nil))) - (error "There is no method for the generic function ~S~%~ - which matches the ARGUMENT-SPECIFIERS ~S." - generic-function - argument-specifiers)) - (t - (remove-method generic-function method))))) - +;;; These two are scheduled for demolition. (defun real-add-named-method (generic-function-name - qualifiers - specializers - lambda-list - &rest other-initargs) + qualifiers + specializers + lambda-list + &rest other-initargs) (unless (and (fboundp generic-function-name) - (typep (name-get-fdefinition generic-function-name) - 'generic-function)) - (sb-kernel::style-warn "implicitly creating new generic function ~S" - generic-function-name)) + (typep (fdefinition generic-function-name) 'generic-function)) + (style-warn "implicitly creating new generic function ~S" + generic-function-name)) ;; XXX What about changing the class of the generic function if ;; there is one? Whose job is that, anyway? Do we need something ;; kind of like CLASS-FOR-REDEFINITION? (let* ((generic-function - (ensure-generic-function generic-function-name)) - (specs (parse-specializers specializers)) - (proto (method-prototype-for-gf generic-function-name)) - (new (apply #'make-instance (class-of proto) - :qualifiers qualifiers - :specializers specs - :lambda-list lambda-list - other-initargs))) - (add-method generic-function new))) + (ensure-generic-function generic-function-name)) + (specs (parse-specializers specializers)) + (proto (method-prototype-for-gf generic-function-name)) + (new (apply #'make-instance (class-of proto) + :qualifiers qualifiers + :specializers specs + :lambda-list lambda-list + other-initargs))) + (add-method generic-function new) + new)) + +(define-condition find-method-length-mismatch + (reference-condition simple-error) + () + (:default-initargs :references (list '(:ansi-cl :function find-method)))) (defun real-get-method (generic-function qualifiers specializers - &optional (errorp t)) - (let ((hit - (dolist (method (generic-function-methods generic-function)) - (when (and (equal qualifiers (method-qualifiers method)) - (every #'same-specializer-p specializers - (method-specializers method))) - (return method))))) - (cond (hit hit) - ((null errorp) nil) - (t - (error "no method on ~S with qualifiers ~:S and specializers ~:S" - generic-function qualifiers specializers))))) - + &optional (errorp t) + always-check-specializers) + (let ((lspec (length specializers)) + (methods (generic-function-methods generic-function))) + (when (or methods always-check-specializers) + (let ((nreq (length (arg-info-metatypes (gf-arg-info + generic-function))))) + ;; Since we internally bypass FIND-METHOD by using GET-METHOD + ;; instead we need to to this here or users may get hit by a + ;; failed AVER instead of a sensible error message. + (when (/= lspec nreq) + (error + 'find-method-length-mismatch + :format-control + "~@" + :format-arguments (list generic-function nreq specializers))))) + (let ((hit + (dolist (method methods) + (let ((mspecializers (method-specializers method))) + (aver (= lspec (length mspecializers))) + (when (and (equal qualifiers (method-qualifiers method)) + (every #'same-specializer-p specializers + (method-specializers method))) + (return method)))))) + (cond (hit hit) + ((null errorp) nil) + (t + (error "~@" + generic-function qualifiers specializers)))))) + (defmethod find-method ((generic-function standard-generic-function) - qualifiers specializers &optional (errorp t)) - (real-get-method generic-function qualifiers - (parse-specializers specializers) errorp)) + qualifiers specializers &optional (errorp t)) + ;; ANSI about FIND-METHOD: "The specializers argument contains the + ;; parameter specializers for the method. It must correspond in + ;; length to the number of required arguments of the generic + ;; function, or an error is signaled." + ;; + ;; This error checking is done by REAL-GET-METHOD. + (real-get-method generic-function + qualifiers + (parse-specializers specializers) + errorp + t)) ;;; Compute various information about a generic-function's arglist by looking ;;; at the argument lists of the methods. The hair for trying not to use @@ -364,60 +374,73 @@ ;;; specializes (e.g. for a classical generic-function this is the ;;; list: (1)). (defmethod compute-discriminating-function-arglist-info - ((generic-function standard-generic-function)) + ((generic-function standard-generic-function)) ;;(declare (values number-of-required-arguments &rest-argument-p - ;; specialized-argument-postions)) + ;; specialized-argument-postions)) (let ((number-required nil) - (restp nil) - (specialized-positions ()) - (methods (generic-function-methods generic-function))) + (restp nil) + (specialized-positions ()) + (methods (generic-function-methods generic-function))) (dolist (method methods) (multiple-value-setq (number-required restp specialized-positions) - (compute-discriminating-function-arglist-info-internal - generic-function method number-required restp specialized-positions))) + (compute-discriminating-function-arglist-info-internal + generic-function method number-required restp specialized-positions))) (values number-required restp (sort specialized-positions #'<)))) (defun compute-discriminating-function-arglist-info-internal (generic-function method number-of-requireds restp - specialized-argument-positions) + specialized-argument-positions) (declare (ignore generic-function) - (type (or null fixnum) number-of-requireds)) + (type (or null fixnum) number-of-requireds)) (let ((requireds 0)) (declare (fixnum requireds)) ;; Go through this methods arguments seeing how many are required, ;; and whether there is an &rest argument. (dolist (arg (method-lambda-list method)) (cond ((eq arg '&aux) (return)) - ((memq arg '(&optional &rest &key)) - (return (setq restp t))) - ((memq arg lambda-list-keywords)) - (t (incf requireds)))) + ((memq arg '(&optional &rest &key)) + (return (setq restp t))) + ((memq arg lambda-list-keywords)) + (t (incf requireds)))) ;; Now go through this method's type specifiers to see which ;; argument positions are type specified. Treat T specially ;; in the usual sort of way. For efficiency don't bother to ;; keep specialized-argument-positions sorted, rather depend ;; on our caller to do that. - (iterate ((type-spec (list-elements (method-specializers method))) - (pos (interval :from 0))) - (unless (eq type-spec *the-class-t*) - (pushnew pos specialized-argument-positions))) + (let ((pos 0)) + (dolist (type-spec (method-specializers method)) + (unless (eq type-spec *the-class-t*) + (pushnew pos specialized-argument-positions)) + (incf pos))) ;; Finally merge the values for this method into the values ;; for the exisiting methods and return them. Note that if ;; num-of-requireds is NIL it means this is the first method ;; and we depend on that. (values (min (or number-of-requireds requireds) requireds) - (or restp - (and number-of-requireds (/= number-of-requireds requireds))) - specialized-argument-positions))) + (or restp + (and number-of-requireds (/= number-of-requireds requireds))) + specialized-argument-positions))) (defun make-discriminating-function-arglist (number-required-arguments restp) - (nconc (gathering ((args (collecting))) - (iterate ((i (interval :from 0 :below number-required-arguments))) - (gather (intern (format nil "Discriminating Function Arg ~D" i)) - args))) - (when restp - `(&rest ,(intern "Discriminating Function &rest Arg"))))) + (nconc (let ((args nil)) + (dotimes (i number-required-arguments) + (push (format-symbol *package* ;; ! is this right? + "Discriminating Function Arg ~D" + i) + args)) + (nreverse args)) + (when restp + `(&rest ,(format-symbol *package* + "Discriminating Function &rest Arg"))))) +(defmethod generic-function-argument-precedence-order + ((gf standard-generic-function)) + (aver (eq *boot-state* 'complete)) + (loop with arg-info = (gf-arg-info gf) + with lambda-list = (arg-info-lambda-list arg-info) + for argument-position in (arg-info-precedence arg-info) + collect (nth argument-position lambda-list))) + (defmethod generic-function-lambda-list ((gf generic-function)) (gf-lambda-list gf)) @@ -425,136 +448,186 @@ (gf-info-fast-mf-p (slot-value gf 'arg-info))) (defmethod initialize-instance :after ((gf standard-generic-function) - &key (lambda-list nil lambda-list-p) - argument-precedence-order) - (with-slots (arg-info) - gf + &key (lambda-list nil lambda-list-p) + argument-precedence-order) + (with-slots (arg-info) gf (if lambda-list-p - (set-arg-info gf - :lambda-list lambda-list - :argument-precedence-order argument-precedence-order) - (set-arg-info gf)) + (set-arg-info gf + :lambda-list lambda-list + :argument-precedence-order argument-precedence-order) + (set-arg-info gf)) (when (arg-info-valid-p arg-info) (update-dfun gf)))) -(defmethod reinitialize-instance :after ((gf standard-generic-function) - &rest args - &key (lambda-list nil lambda-list-p) - (argument-precedence-order - nil argument-precedence-order-p)) - (with-slots (arg-info) - gf - (if lambda-list-p - (if argument-precedence-order-p - (set-arg-info gf - :lambda-list lambda-list - :argument-precedence-order argument-precedence-order) - (set-arg-info gf - :lambda-list lambda-list)) - (set-arg-info gf)) - (when (and (arg-info-valid-p arg-info) - args - (or lambda-list-p (cddr args))) - (update-dfun gf)))) +(defmethod reinitialize-instance :around + ((gf standard-generic-function) &rest args &key + (lambda-list nil lambda-list-p) (argument-precedence-order nil apo-p)) + (let ((old-mc (generic-function-method-combination gf))) + (prog1 (call-next-method) + ;; KLUDGE: EQ is too strong a test. + (unless (eq old-mc (generic-function-method-combination gf)) + (flush-effective-method-cache gf)) + (cond + ((and lambda-list-p apo-p) + (set-arg-info gf + :lambda-list lambda-list + :argument-precedence-order argument-precedence-order)) + (lambda-list-p (set-arg-info gf :lambda-list lambda-list)) + (t (set-arg-info gf))) + (when (arg-info-valid-p (gf-arg-info gf)) + (update-dfun gf)) + (map-dependents gf (lambda (dependent) + (apply #'update-dependent gf dependent args)))))) (declaim (special *lazy-dfun-compute-p*)) (defun set-methods (gf methods) (setf (generic-function-methods gf) nil) (loop (when (null methods) (return gf)) - (real-add-method gf (pop methods) methods))) + (real-add-method gf (pop methods) methods))) (defun real-add-method (generic-function method &optional skip-dfun-update-p) - (if (method-generic-function method) - (error "The method ~S is already part of the generic~@ - function ~S. It can't be added to another generic~@ - function until it is removed from the first one." - method (method-generic-function method)) - + (when (method-generic-function method) + (error "~@" + method (method-generic-function method))) + (flet ((similar-lambda-lists-p (method-a method-b) + (multiple-value-bind (a-nreq a-nopt a-keyp a-restp) + (analyze-lambda-list (method-lambda-list method-a)) + (multiple-value-bind (b-nreq b-nopt b-keyp b-restp) + (analyze-lambda-list (method-lambda-list method-b)) + (and (= a-nreq b-nreq) + (= a-nopt b-nopt) + (eq (or a-keyp a-restp) + (or b-keyp b-restp))))))) (let* ((name (generic-function-name generic-function)) - (qualifiers (method-qualifiers method)) - (specializers (method-specializers method)) - (existing (get-method generic-function - qualifiers - specializers - nil))) - - ;; If there is already a method like this one then we must - ;; get rid of it before proceeding. Note that we call the - ;; generic function remove-method to remove it rather than - ;; doing it in some internal way. - (when existing (remove-method generic-function existing)) - - (setf (method-generic-function method) generic-function) - (pushnew method (generic-function-methods generic-function)) - (dolist (specializer specializers) - (add-direct-method specializer method)) - (set-arg-info generic-function :new-method method) - (unless skip-dfun-update-p - (when (member name - '(make-instance default-initargs - allocate-instance shared-initialize - initialize-instance)) - (update-make-instance-function-table (type-class - (car specializers)))) - (update-dfun generic-function)) - method))) + (qualifiers (method-qualifiers method)) + (specializers (method-specializers method)) + (existing (get-method generic-function + qualifiers + specializers + nil))) + + ;; If there is already a method like this one then we must get + ;; rid of it before proceeding. Note that we call the generic + ;; function REMOVE-METHOD to remove it rather than doing it in + ;; some internal way. + (when (and existing (similar-lambda-lists-p existing method)) + (remove-method generic-function existing)) + + (setf (method-generic-function method) generic-function) + (pushnew method (generic-function-methods generic-function)) + (dolist (specializer specializers) + (add-direct-method specializer method)) + + ;; KLUDGE: SET-ARG-INFO contains the error-detecting logic for + ;; detecting attempts to add methods with incongruent lambda + ;; lists. However, according to Gerd Moellmann on cmucl-imp, + ;; it also depends on the new method already having been added + ;; to the generic function. Therefore, we need to remove it + ;; again on error: + (let ((remove-again-p t)) + (unwind-protect + (progn + (set-arg-info generic-function :new-method method) + (setq remove-again-p nil)) + (when remove-again-p + (remove-method generic-function method)))) + + ;; KLUDGE II: ANSI saith that it is not an error to add a + ;; method with invalid qualifiers to a generic function of the + ;; wrong kind; it's only an error at generic function + ;; invocation time; I dunno what the rationale was, and it + ;; sucks. Nevertheless, it's probably a programmer error, so + ;; let's warn anyway. -- CSR, 2003-08-20 + (let ((mc (generic-function-method-combination generic-functioN))) + (cond + ((eq mc *standard-method-combination*) + (when (and qualifiers + (or (cdr qualifiers) + (not (memq (car qualifiers) + '(:around :before :after))))) + (warn "~@" + method qualifiers))) + ((short-method-combination-p mc) + (let ((mc-name (method-combination-type mc))) + (when (or (null qualifiers) + (cdr qualifiers) + (and (neq (car qualifiers) :around) + (neq (car qualifiers) mc-name))) + (warn "~@" + mc-name method qualifiers)))))) + + (unless skip-dfun-update-p + (update-ctors 'add-method + :generic-function generic-function + :method method) + (update-dfun generic-function)) + (map-dependents generic-function + (lambda (dep) + (update-dependent generic-function + dep 'add-method method))) + generic-function))) (defun real-remove-method (generic-function method) - ;; Note: Error check prohibited by ANSI spec removed. (when (eq generic-function (method-generic-function method)) - (let* ((name (generic-function-name generic-function)) - (specializers (method-specializers method)) - (methods (generic-function-methods generic-function)) - (new-methods (remove method methods))) + (let* ((name (generic-function-name generic-function)) + (specializers (method-specializers method)) + (methods (generic-function-methods generic-function)) + (new-methods (remove method methods))) (setf (method-generic-function method) nil) (setf (generic-function-methods generic-function) new-methods) (dolist (specializer (method-specializers method)) - (remove-direct-method specializer method)) + (remove-direct-method specializer method)) (set-arg-info generic-function) - (when (member name - '(make-instance - default-initargs - allocate-instance shared-initialize initialize-instance)) - (update-make-instance-function-table (type-class (car specializers)))) + (update-ctors 'remove-method + :generic-function generic-function + :method method) (update-dfun generic-function) + (map-dependents generic-function + (lambda (dep) + (update-dependent generic-function + dep 'remove-method method))) generic-function))) (defun compute-applicable-methods-function (generic-function arguments) (values (compute-applicable-methods-using-types - generic-function - (types-from-arguments generic-function arguments 'eql)))) + generic-function + (types-from-args generic-function arguments 'eql)))) (defmethod compute-applicable-methods ((generic-function generic-function) arguments) (values (compute-applicable-methods-using-types - generic-function - (types-from-arguments generic-function arguments 'eql)))) + generic-function + (types-from-args generic-function arguments 'eql)))) (defmethod compute-applicable-methods-using-classes ((generic-function generic-function) classes) (compute-applicable-methods-using-types generic-function - (types-from-arguments generic-function classes 'class-eq))) + (types-from-args generic-function classes 'class-eq))) (defun proclaim-incompatible-superclasses (classes) - (setq classes (mapcar #'(lambda (class) - (if (symbolp class) - (find-class class) - class)) - classes)) + (setq classes (mapcar (lambda (class) + (if (symbolp class) + (find-class class) + class)) + classes)) (dolist (class classes) (dolist (other-class classes) (unless (eq class other-class) - (pushnew other-class (class-incompatible-superclass-list class)))))) + (pushnew other-class (class-incompatible-superclass-list class)))))) (defun superclasses-compatible-p (class1 class2) - (let ((cpl1 (class-precedence-list class1)) - (cpl2 (class-precedence-list class2))) + (let ((cpl1 (cpl-or-nil class1)) + (cpl2 (cpl-or-nil class2))) (dolist (sc1 cpl1 t) (dolist (ic (class-incompatible-superclass-list sc1)) - (when (memq ic cpl2) - (return-from superclasses-compatible-p nil)))))) + (when (memq ic cpl2) + (return-from superclasses-compatible-p nil)))))) (mapc #'proclaim-incompatible-superclasses @@ -565,15 +638,15 @@ (class eql-specializer class-eq-specializer method method-combination generic-function slot-definition) ;; metaclass built-in-class - (number sequence character ; direct subclasses of t, but not array - standard-object structure-object) ; or symbol + (number sequence character ; direct subclasses of t, but not array + standard-object structure-object) ; or symbol (number array character symbol ; direct subclasses of t, but not - standard-object structure-object) ; sequence - (complex float rational) ; direct subclasses of number - (integer ratio) ; direct subclasses of rational - (list vector) ; direct subclasses of sequence - (cons null) ; direct subclasses of list - (string bit-vector) ; direct subclasses of vector + standard-object structure-object) ; sequence + (complex float rational) ; direct subclasses of number + (integer ratio) ; direct subclasses of rational + (list vector) ; direct subclasses of sequence + (cons null) ; direct subclasses of list + (string bit-vector) ; direct subclasses of vector )) (defmethod same-specializer-p ((specl1 specializer) (specl2 specializer)) @@ -586,11 +659,11 @@ specializer) (defmethod same-specializer-p ((specl1 class-eq-specializer) - (specl2 class-eq-specializer)) + (specl2 class-eq-specializer)) (eq (specializer-class specl1) (specializer-class specl2))) (defmethod same-specializer-p ((specl1 eql-specializer) - (specl2 eql-specializer)) + (specl2 eql-specializer)) (eq (specializer-object specl1) (specializer-object specl2))) (defmethod specializer-class ((specializer eql-specializer)) @@ -599,83 +672,90 @@ (defvar *in-gf-arg-info-p* nil) (setf (gdefinition 'arg-info-reader) (let ((mf (initialize-method-function - (make-internal-reader-method-function - 'standard-generic-function 'arg-info) - t))) - #'(lambda (&rest args) (funcall mf args nil)))) + (make-internal-reader-method-function + 'standard-generic-function 'arg-info) + t))) + (lambda (&rest args) (funcall mf args nil)))) -(defun types-from-arguments (generic-function arguments - &optional type-modifier) + +(defun error-need-at-least-n-args (function n) + (error 'simple-program-error + :format-control "~@" + :format-arguments (list function n))) + +(defun types-from-args (generic-function arguments &optional type-modifier) (multiple-value-bind (nreq applyp metatypes nkeys arg-info) - (get-generic-function-info generic-function) + (get-generic-fun-info generic-function) (declare (ignore applyp metatypes nkeys)) (let ((types-rev nil)) (dotimes-fixnum (i nreq) - i - (unless arguments - (error "The function ~S requires at least ~D arguments" - (generic-function-name generic-function) - nreq)) - (let ((arg (pop arguments))) - (push (if type-modifier `(,type-modifier ,arg) arg) types-rev))) + i + (unless arguments + (error-need-at-least-n-args (generic-function-name generic-function) + nreq)) + (let ((arg (pop arguments))) + (push (if type-modifier `(,type-modifier ,arg) arg) types-rev))) (values (nreverse types-rev) arg-info)))) (defun get-wrappers-from-classes (nkeys wrappers classes metatypes) (let* ((w wrappers) (w-tail w) (mt-tail metatypes)) (dolist (class (if (listp classes) classes (list classes))) - (unless (eq 't (car mt-tail)) - (let ((c-w (class-wrapper class))) - (unless c-w (return-from get-wrappers-from-classes nil)) - (if (eql nkeys 1) - (setq w c-w) - (setf (car w-tail) c-w - w-tail (cdr w-tail))))) + (unless (eq t (car mt-tail)) + (let ((c-w (class-wrapper class))) + (unless c-w (return-from get-wrappers-from-classes nil)) + (if (eql nkeys 1) + (setq w c-w) + (setf (car w-tail) c-w + w-tail (cdr w-tail))))) (setq mt-tail (cdr mt-tail))) w)) (defun sdfun-for-caching (gf classes) (let ((types (mapcar #'class-eq-type classes))) (multiple-value-bind (methods all-applicable-and-sorted-p) - (compute-applicable-methods-using-types gf types) - (function-funcall (get-secondary-dispatch-function1 - gf methods types nil t all-applicable-and-sorted-p) - nil (mapcar #'class-wrapper classes))))) + (compute-applicable-methods-using-types gf types) + (let ((generator (get-secondary-dispatch-function1 + gf methods types nil t all-applicable-and-sorted-p))) + (make-callable gf methods generator + nil (mapcar #'class-wrapper classes)))))) (defun value-for-caching (gf classes) (let ((methods (compute-applicable-methods-using-types - gf (mapcar #'class-eq-type classes)))) + gf (mapcar #'class-eq-type classes)))) (method-function-get (or (method-fast-function (car methods)) - (method-function (car methods))) - :constant-value))) + (method-function (car methods))) + :constant-value))) (defun default-secondary-dispatch-function (generic-function) - #'(lambda (&rest args) - (let ((methods (compute-applicable-methods generic-function args))) - (if methods - (let ((emf (get-effective-method-function generic-function - methods))) - (invoke-emf emf args)) - (apply #'no-applicable-method generic-function args))))) + (lambda (&rest args) + (let ((methods (compute-applicable-methods generic-function args))) + (if methods + (let ((emf (get-effective-method-function generic-function + methods))) + (invoke-emf emf args)) + (apply #'no-applicable-method generic-function args))))) (defun list-eq (x y) (loop (when (atom x) (return (eq x y))) - (when (atom y) (return nil)) - (unless (eq (car x) (car y)) (return nil)) - (setq x (cdr x) y (cdr y)))) + (when (atom y) (return nil)) + (unless (eq (car x) (car y)) (return nil)) + (setq x (cdr x) + y (cdr y)))) (defvar *std-cam-methods* nil) (defun compute-applicable-methods-emf (generic-function) (if (eq *boot-state* 'complete) (let* ((cam (gdefinition 'compute-applicable-methods)) - (cam-methods (compute-applicable-methods-using-types - cam (list `(eql ,generic-function) t)))) - (values (get-effective-method-function cam cam-methods) - (list-eq cam-methods - (or *std-cam-methods* - (setq *std-cam-methods* - (compute-applicable-methods-using-types - cam (list `(eql ,cam) t))))))) + (cam-methods (compute-applicable-methods-using-types + cam (list `(eql ,generic-function) t)))) + (values (get-effective-method-function cam cam-methods) + (list-eq cam-methods + (or *std-cam-methods* + (setq *std-cam-methods* + (compute-applicable-methods-using-types + cam (list `(eql ,cam) t))))))) (values #'compute-applicable-methods-function t))) (defun compute-applicable-methods-emf-std-p (gf) @@ -686,25 +766,25 @@ (defun update-all-c-a-m-gf-info (c-a-m-gf) (let ((methods (generic-function-methods c-a-m-gf))) (if (and *old-c-a-m-gf-methods* - (every #'(lambda (old-method) - (member old-method methods)) - *old-c-a-m-gf-methods*)) - (let ((gfs-to-do nil) - (gf-classes-to-do nil)) - (dolist (method methods) - (unless (member method *old-c-a-m-gf-methods*) - (let ((specl (car (method-specializers method)))) - (if (eql-specializer-p specl) - (pushnew (specializer-object specl) gfs-to-do) - (pushnew (specializer-class specl) gf-classes-to-do))))) - (map-all-generic-functions - #'(lambda (gf) - (when (or (member gf gfs-to-do) - (dolist (class gf-classes-to-do nil) - (member class - (class-precedence-list (class-of gf))))) - (update-c-a-m-gf-info gf))))) - (map-all-generic-functions #'update-c-a-m-gf-info)) + (every (lambda (old-method) + (member old-method methods)) + *old-c-a-m-gf-methods*)) + (let ((gfs-to-do nil) + (gf-classes-to-do nil)) + (dolist (method methods) + (unless (member method *old-c-a-m-gf-methods*) + (let ((specl (car (method-specializers method)))) + (if (eql-specializer-p specl) + (pushnew (specializer-object specl) gfs-to-do) + (pushnew (specializer-class specl) gf-classes-to-do))))) + (map-all-generic-functions + (lambda (gf) + (when (or (member gf gfs-to-do) + (dolist (class gf-classes-to-do nil) + (member class + (class-precedence-list (class-of gf))))) + (update-c-a-m-gf-info gf))))) + (map-all-generic-functions #'update-c-a-m-gf-info)) (setq *old-c-a-m-gf-methods* methods))) (defun update-gf-info (gf) @@ -714,65 +794,79 @@ (defun update-c-a-m-gf-info (gf) (unless (early-gf-p gf) (multiple-value-bind (c-a-m-emf std-p) - (compute-applicable-methods-emf gf) + (compute-applicable-methods-emf gf) (let ((arg-info (gf-arg-info gf))) - (setf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf) - (setf (gf-info-c-a-m-emf-std-p arg-info) std-p))))) + (setf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf) + (setf (gf-info-c-a-m-emf-std-p arg-info) std-p))))) (defun update-gf-simple-accessor-type (gf) (let ((arg-info (gf-arg-info gf))) (setf (gf-info-simple-accessor-type arg-info) - (let* ((methods (generic-function-methods gf)) - (class (and methods (class-of (car methods)))) - (type (and class - (cond ((eq class - *the-class-standard-reader-method*) - 'reader) - ((eq class - *the-class-standard-writer-method*) - 'writer) - ((eq class - *the-class-standard-boundp-method*) - 'boundp))))) - (when (and (gf-info-c-a-m-emf-std-p arg-info) - type - (dolist (method (cdr methods) t) - (unless (eq class (class-of method)) (return nil))) - (eq (generic-function-method-combination gf) - *standard-method-combination*)) - type))))) - + (let* ((methods (generic-function-methods gf)) + (class (and methods (class-of (car methods)))) + (type (and class + (cond ((eq class + *the-class-standard-reader-method*) + 'reader) + ((eq class + *the-class-standard-writer-method*) + 'writer) + ((eq class + *the-class-standard-boundp-method*) + 'boundp))))) + (when (and (gf-info-c-a-m-emf-std-p arg-info) + type + (dolist (method (cdr methods) t) + (unless (eq class (class-of method)) (return nil))) + (eq (generic-function-method-combination gf) + *standard-method-combination*)) + type))))) + + +;;; CMUCL (Gerd's PCL, 2002-04-25) comment: +;;; +;;; Return two values. First value is a function to be stored in +;;; effective slot definition SLOTD for reading it with +;;; SLOT-VALUE-USING-CLASS, setting it with (SETF +;;; SLOT-VALUE-USING-CLASS) or testing it with +;;; SLOT-BOUNDP-USING-CLASS. GF is one of these generic functions, +;;; TYPE is one of the symbols READER, WRITER, BOUNDP. CLASS is +;;; SLOTD's class. +;;; +;;; Second value is true if the function returned is one of the +;;; optimized standard functions for the purpose, which are used +;;; when only standard methods are applicable. +;;; +;;; FIXME: Change all these wacky function names to something sane. (defun get-accessor-method-function (gf type class slotd) (let* ((std-method (standard-svuc-method type)) - (str-method (structure-svuc-method type)) - (types1 `((eql ,class) (class-eq ,class) (eql ,slotd))) - (types (if (eq type 'writer) `(t ,@types1) types1)) - (methods (compute-applicable-methods-using-types gf types)) - (std-p (null (cdr methods)))) + (str-method (structure-svuc-method type)) + (types1 `((eql ,class) (class-eq ,class) (eql ,slotd))) + (types (if (eq type 'writer) `(t ,@types1) types1)) + (methods (compute-applicable-methods-using-types gf types)) + (std-p (null (cdr methods)))) (values (if std-p - (get-optimized-std-accessor-method-function class slotd type) - (get-accessor-from-svuc-method-function - class slotd - (get-secondary-dispatch-function - gf methods types - `((,(car (or (member std-method methods) - (member str-method methods) - (error "error in get-accessor-method-function"))) - ,(get-optimized-std-slot-value-using-class-method-function - class slotd type))) - (unless (and (eq type 'writer) - (dolist (method methods t) - (unless (eq (car (method-specializers method)) - *the-class-t*) - (return nil)))) - (let ((wrappers (list (wrapper-of class) - (class-wrapper class) - (wrapper-of slotd)))) - (if (eq type 'writer) - (cons (class-wrapper *the-class-t*) wrappers) - wrappers)))) - type)) + (get-optimized-std-accessor-method-function class slotd type) + (let* ((optimized-std-fun + (get-optimized-std-slot-value-using-class-method-function + class slotd type)) + (method-alist + `((,(car (or (member std-method methods) + (member str-method methods) + (bug "error in ~S" + 'get-accessor-method-function))) + ,optimized-std-fun))) + (wrappers + (let ((wrappers (list (wrapper-of class) + (class-wrapper class) + (wrapper-of slotd)))) + (if (eq type 'writer) + (cons (class-wrapper *the-class-t*) wrappers) + wrappers))) + (sdfun (get-secondary-dispatch-function + gf methods types method-alist wrappers))) + (get-accessor-from-svuc-method-function class slotd sdfun type))) std-p))) ;;; used by OPTIMIZE-SLOT-VALUE-BY-CLASS-P (vector.lisp) @@ -781,16 +875,19 @@ (update-std-or-str-methods gf type)) (when (and (standard-svuc-method type) (structure-svuc-method type)) (flet ((update-class (class) - (when (class-finalized-p class) - (dolist (slotd (class-slots class)) - (compute-slot-accessor-info slotd type gf))))) + (when (class-finalized-p class) + (dolist (slotd (class-slots class)) + (compute-slot-accessor-info slotd type gf))))) (if *new-class* - (update-class *new-class*) - (map-all-classes #'update-class 'slot-object))))) + (update-class *new-class*) + (map-all-classes #'update-class 'slot-object))))) (defvar *standard-slot-value-using-class-method* nil) (defvar *standard-setf-slot-value-using-class-method* nil) (defvar *standard-slot-boundp-using-class-method* nil) +(defvar *condition-slot-value-using-class-method* nil) +(defvar *condition-setf-slot-value-using-class-method* nil) +(defvar *condition-slot-boundp-using-class-method* nil) (defvar *structure-slot-value-using-class-method* nil) (defvar *structure-setf-slot-value-using-class-method* nil) (defvar *structure-slot-boundp-using-class-method* nil) @@ -807,6 +904,18 @@ (writer (setq *standard-setf-slot-value-using-class-method* method)) (boundp (setq *standard-slot-boundp-using-class-method* method)))) +(defun condition-svuc-method (type) + (case type + (reader *condition-slot-value-using-class-method*) + (writer *condition-setf-slot-value-using-class-method*) + (boundp *condition-slot-boundp-using-class-method*))) + +(defun set-condition-svuc-method (type method) + (case type + (reader (setq *condition-slot-value-using-class-method* method)) + (writer (setq *condition-setf-slot-value-using-class-method* method)) + (boundp (setq *condition-slot-boundp-using-class-method* method)))) + (defun structure-svuc-method (type) (case type (reader *structure-slot-value-using-class-method*) @@ -823,105 +932,103 @@ (dolist (method (generic-function-methods gf)) (let ((specls (method-specializers method))) (when (and (or (not (eq type 'writer)) - (eq (pop specls) *the-class-t*)) - (every #'classp specls)) - (cond ((and (eq (class-name (car specls)) - 'std-class) - (eq (class-name (cadr specls)) - 'std-object) - (eq (class-name (caddr specls)) - 'standard-effective-slot-definition)) - (set-standard-svuc-method type method)) - ((and (eq (class-name (car specls)) - 'structure-class) - (eq (class-name (cadr specls)) - 'structure-object) - (eq (class-name (caddr specls)) - 'structure-effective-slot-definition)) - (set-structure-svuc-method type method))))))) + (eq (pop specls) *the-class-t*)) + (every #'classp specls)) + (cond ((and (eq (class-name (car specls)) 'std-class) + (eq (class-name (cadr specls)) 'standard-object) + (eq (class-name (caddr specls)) + 'standard-effective-slot-definition)) + (set-standard-svuc-method type method)) + ((and (eq (class-name (car specls)) 'condition-class) + (eq (class-name (cadr specls)) 'condition) + (eq (class-name (caddr specls)) + 'condition-effective-slot-definition)) + (set-condition-svuc-method type method)) + ((and (eq (class-name (car specls)) 'structure-class) + (eq (class-name (cadr specls)) 'structure-object) + (eq (class-name (caddr specls)) + 'structure-effective-slot-definition)) + (set-structure-svuc-method type method))))))) (defun mec-all-classes-internal (spec precompute-p) (cons (specializer-class spec) - (and (classp spec) - precompute-p - (not (or (eq spec *the-class-t*) - (eq spec *the-class-slot-object*) - (eq spec *the-class-std-object*) - (eq spec *the-class-standard-object*) - (eq spec *the-class-structure-object*))) - (let ((sc (class-direct-subclasses spec))) - (when sc - (mapcan #'(lambda (class) - (mec-all-classes-internal class precompute-p)) - sc)))))) + (and (classp spec) + precompute-p + (not (or (eq spec *the-class-t*) + (eq spec *the-class-slot-object*) + (eq spec *the-class-standard-object*) + (eq spec *the-class-structure-object*))) + (let ((sc (class-direct-subclasses spec))) + (when sc + (mapcan (lambda (class) + (mec-all-classes-internal class precompute-p)) + sc)))))) (defun mec-all-classes (spec precompute-p) (let ((classes (mec-all-classes-internal spec precompute-p))) (if (null (cdr classes)) - classes - (let* ((a-classes (cons nil classes)) - (tail classes)) - (loop (when (null (cdr tail)) - (return (cdr a-classes))) - (let ((class (cadr tail)) - (ttail (cddr tail))) - (if (dolist (c ttail nil) - (when (eq class c) (return t))) - (setf (cdr tail) (cddr tail)) - (setf tail (cdr tail))))))))) + classes + (let* ((a-classes (cons nil classes)) + (tail classes)) + (loop (when (null (cdr tail)) + (return (cdr a-classes))) + (let ((class (cadr tail)) + (ttail (cddr tail))) + (if (dolist (c ttail nil) + (when (eq class c) (return t))) + (setf (cdr tail) (cddr tail)) + (setf tail (cdr tail))))))))) (defun mec-all-class-lists (spec-list precompute-p) (if (null spec-list) (list nil) (let* ((car-all-classes (mec-all-classes (car spec-list) - precompute-p)) - (all-class-lists (mec-all-class-lists (cdr spec-list) - precompute-p))) - (mapcan #'(lambda (list) - (mapcar #'(lambda (c) (cons c list)) car-all-classes)) - all-class-lists)))) + precompute-p)) + (all-class-lists (mec-all-class-lists (cdr spec-list) + precompute-p))) + (mapcan (lambda (list) + (mapcar (lambda (c) (cons c list)) car-all-classes)) + all-class-lists)))) (defun make-emf-cache (generic-function valuep cache classes-list new-class) (let* ((arg-info (gf-arg-info generic-function)) - (nkeys (arg-info-nkeys arg-info)) - (metatypes (arg-info-metatypes arg-info)) - (wrappers (unless (eq nkeys 1) (make-list nkeys))) - (precompute-p (gf-precompute-dfun-and-emf-p arg-info)) - (default '(default))) + (nkeys (arg-info-nkeys arg-info)) + (metatypes (arg-info-metatypes arg-info)) + (wrappers (unless (eq nkeys 1) (make-list nkeys))) + (precompute-p (gf-precompute-dfun-and-emf-p arg-info)) + (default '(default))) (flet ((add-class-list (classes) - (when (or (null new-class) (memq new-class classes)) - (let ((wrappers (get-wrappers-from-classes - nkeys wrappers classes metatypes))) - (when (and wrappers - (eq default (probe-cache cache wrappers default))) - (let ((value (cond ((eq valuep t) - (sdfun-for-caching generic-function - classes)) - ((eq valuep :constant-value) - (value-for-caching generic-function - classes))))) - (setq cache (fill-cache cache wrappers value t)))))))) + (when (or (null new-class) (memq new-class classes)) + (let ((wrappers (get-wrappers-from-classes + nkeys wrappers classes metatypes))) + (when (and wrappers + (eq default (probe-cache cache wrappers default))) + (let ((value (cond ((eq valuep t) + (sdfun-for-caching generic-function + classes)) + ((eq valuep :constant-value) + (value-for-caching generic-function + classes))))) + (setq cache (fill-cache cache wrappers value)))))))) (if classes-list - (mapc #'add-class-list classes-list) - (dolist (method (generic-function-methods generic-function)) - (mapc #'add-class-list - (mec-all-class-lists (method-specializers method) - precompute-p)))) + (mapc #'add-class-list classes-list) + (dolist (method (generic-function-methods generic-function)) + (mapc #'add-class-list + (mec-all-class-lists (method-specializers method) + precompute-p)))) cache))) (defmacro class-test (arg class) - (cond ((eq class *the-class-t*) - 't) - ((eq class *the-class-slot-object*) - `(not (cl:typep (cl:class-of ,arg) 'cl:built-in-class))) - ((eq class *the-class-std-object*) - `(or (std-instance-p ,arg) (fsc-instance-p ,arg))) - ((eq class *the-class-standard-object*) - `(std-instance-p ,arg)) - ((eq class *the-class-funcallable-standard-object*) - `(fsc-instance-p ,arg)) - (t - `(typep ,arg ',(class-name class))))) + (cond + ((eq class *the-class-t*) t) + ((eq class *the-class-slot-object*) + `(not (typep (classoid-of ,arg) 'built-in-classoid))) + ((eq class *the-class-standard-object*) + `(or (std-instance-p ,arg) (fsc-instance-p ,arg))) + ((eq class *the-class-funcallable-standard-object*) + `(fsc-instance-p ,arg)) + (t + `(typep ,arg ',(class-name class))))) (defmacro class-eq-test (arg class) `(eq (class-of ,arg) ',class)) @@ -932,236 +1039,242 @@ (defun dnet-methods-p (form) (and (consp form) (or (eq (car form) 'methods) - (eq (car form) 'unordered-methods)))) + (eq (car form) 'unordered-methods)))) ;;; This is CASE, but without gensyms. (defmacro scase (arg &rest clauses) `(let ((.case-arg. ,arg)) - (cond ,@(mapcar #'(lambda (clause) - (list* (cond ((null (car clause)) - nil) - ((consp (car clause)) - (if (null (cdar clause)) - `(eql .case-arg. - ',(caar clause)) - `(member .case-arg. - ',(car clause)))) - ((member (car clause) '(t otherwise)) - `t) - (t - `(eql .case-arg. ',(car clause)))) - nil - (cdr clause))) - clauses)))) + (cond ,@(mapcar (lambda (clause) + (list* (cond ((null (car clause)) + nil) + ((consp (car clause)) + (if (null (cdar clause)) + `(eql .case-arg. + ',(caar clause)) + `(member .case-arg. + ',(car clause)))) + ((member (car clause) '(t otherwise)) + `t) + (t + `(eql .case-arg. ',(car clause)))) + nil + (cdr clause))) + clauses)))) (defmacro mcase (arg &rest clauses) `(scase ,arg ,@clauses)) (defun generate-discrimination-net (generic-function methods types sorted-p) (let* ((arg-info (gf-arg-info generic-function)) - (precedence (arg-info-precedence arg-info))) + (c-a-m-emf-std-p (gf-info-c-a-m-emf-std-p arg-info)) + (precedence (arg-info-precedence arg-info))) (generate-discrimination-net-internal generic-function methods types - #'(lambda (methods known-types) - (if (or sorted-p - (block one-order-p - (let ((sorted-methods nil)) - (map-all-orders - (copy-list methods) precedence - #'(lambda (methods) - (when sorted-methods (return-from one-order-p nil)) - (setq sorted-methods methods))) - (setq methods sorted-methods)) - t)) - `(methods ,methods ,known-types) - `(unordered-methods ,methods ,known-types))) - #'(lambda (position type true-value false-value) - (let ((arg (dfun-arg-symbol position))) - (if (eq (car type) 'eql) - (let* ((false-case-p (and (consp false-value) - (or (eq (car false-value) 'scase) - (eq (car false-value) 'mcase)) - (eq arg (cadr false-value)))) - (false-clauses (if false-case-p - (cddr false-value) - `((t ,false-value)))) - (case-sym (if (and (dnet-methods-p true-value) - (if false-case-p - (eq (car false-value) 'mcase) - (dnet-methods-p false-value))) - 'mcase - 'scase)) - (type-sym `(,(cadr type)))) - `(,case-sym ,arg - (,type-sym ,true-value) - ,@false-clauses)) - `(if ,(let ((arg (dfun-arg-symbol position))) - (case (car type) - (class `(class-test ,arg ,(cadr type))) - (class-eq `(class-eq-test ,arg ,(cadr type))))) - ,true-value - ,false-value)))) + (lambda (methods known-types) + (if (or sorted-p + (and c-a-m-emf-std-p + (block one-order-p + (let ((sorted-methods nil)) + (map-all-orders + (copy-list methods) precedence + (lambda (methods) + (when sorted-methods (return-from one-order-p nil)) + (setq sorted-methods methods))) + (setq methods sorted-methods)) + t))) + `(methods ,methods ,known-types) + `(unordered-methods ,methods ,known-types))) + (lambda (position type true-value false-value) + (let ((arg (dfun-arg-symbol position))) + (if (eq (car type) 'eql) + (let* ((false-case-p (and (consp false-value) + (or (eq (car false-value) 'scase) + (eq (car false-value) 'mcase)) + (eq arg (cadr false-value)))) + (false-clauses (if false-case-p + (cddr false-value) + `((t ,false-value)))) + (case-sym (if (and (dnet-methods-p true-value) + (if false-case-p + (eq (car false-value) 'mcase) + (dnet-methods-p false-value))) + 'mcase + 'scase)) + (type-sym `(,(cadr type)))) + `(,case-sym ,arg + (,type-sym ,true-value) + ,@false-clauses)) + `(if ,(let ((arg (dfun-arg-symbol position))) + (case (car type) + (class `(class-test ,arg ,(cadr type))) + (class-eq `(class-eq-test ,arg ,(cadr type))))) + ,true-value + ,false-value)))) #'identity))) (defun class-from-type (type) - (if (or (atom type) (eq (car type) 't)) + (if (or (atom type) (eq (car type) t)) *the-class-t* (case (car type) - (and (dolist (type (cdr type) *the-class-t*) - (when (and (consp type) (not (eq (car type) 'not))) - (return (class-from-type type))))) - (not *the-class-t*) - (eql (class-of (cadr type))) - (class-eq (cadr type)) - (class (cadr type))))) + (and (dolist (type (cdr type) *the-class-t*) + (when (and (consp type) (not (eq (car type) 'not))) + (return (class-from-type type))))) + (not *the-class-t*) + (eql (class-of (cadr type))) + (class-eq (cadr type)) + (class (cadr type))))) (defun precompute-effective-methods (gf caching-p &optional classes-list-p) (let* ((arg-info (gf-arg-info gf)) - (methods (generic-function-methods gf)) - (precedence (arg-info-precedence arg-info)) - (*in-precompute-effective-methods-p* t) - (classes-list nil)) + (methods (generic-function-methods gf)) + (precedence (arg-info-precedence arg-info)) + (*in-precompute-effective-methods-p* t) + (classes-list nil)) (generate-discrimination-net-internal gf methods nil - #'(lambda (methods known-types) - (when methods - (when classes-list-p - (push (mapcar #'class-from-type known-types) classes-list)) - (let ((no-eql-specls-p (not (methods-contain-eql-specializer-p - methods)))) - (map-all-orders - methods precedence - #'(lambda (methods) - (get-secondary-dispatch-function1 - gf methods known-types - nil caching-p no-eql-specls-p)))))) - #'(lambda (position type true-value false-value) - (declare (ignore position type true-value false-value)) - nil) - #'(lambda (type) - (if (and (consp type) (eq (car type) 'eql)) - `(class-eq ,(class-of (cadr type))) - type))) + (lambda (methods known-types) + (when methods + (when classes-list-p + (push (mapcar #'class-from-type known-types) classes-list)) + (let ((no-eql-specls-p (not (methods-contain-eql-specializer-p + methods)))) + (map-all-orders + methods precedence + (lambda (methods) + (get-secondary-dispatch-function1 + gf methods known-types + nil caching-p no-eql-specls-p)))))) + (lambda (position type true-value false-value) + (declare (ignore position type true-value false-value)) + nil) + (lambda (type) + (if (and (consp type) (eq (car type) 'eql)) + `(class-eq ,(class-of (cadr type))) + type))) classes-list)) ;;; We know that known-type implies neither new-type nor `(not ,new-type). (defun augment-type (new-type known-type) - (if (or (eq known-type 't) - (eq (car new-type) 'eql)) + (if (or (eq known-type t) + (eq (car new-type) 'eql)) new-type (let ((so-far (if (and (consp known-type) (eq (car known-type) 'and)) - (cdr known-type) - (list known-type)))) - (unless (eq (car new-type) 'not) - (setq so-far - (mapcan #'(lambda (type) - (unless (*subtypep new-type type) - (list type))) - so-far))) - (if (null so-far) - new-type - `(and ,new-type ,@so-far))))) + (cdr known-type) + (list known-type)))) + (unless (eq (car new-type) 'not) + (setq so-far + (mapcan (lambda (type) + (unless (*subtypep new-type type) + (list type))) + so-far))) + (if (null so-far) + new-type + `(and ,new-type ,@so-far))))) (defun generate-discrimination-net-internal - (gf methods types methods-function test-function type-function) + (gf methods types methods-function test-fun type-function) (let* ((arg-info (gf-arg-info gf)) - (precedence (arg-info-precedence arg-info)) - (nreq (arg-info-number-required arg-info)) - (metatypes (arg-info-metatypes arg-info))) + (precedence (arg-info-precedence arg-info)) + (nreq (arg-info-number-required arg-info)) + (metatypes (arg-info-metatypes arg-info))) (labels ((do-column (p-tail contenders known-types) - (if p-tail - (let* ((position (car p-tail)) - (known-type (or (nth position types) t))) - (if (eq (nth position metatypes) 't) - (do-column (cdr p-tail) contenders - (cons (cons position known-type) - known-types)) - (do-methods p-tail contenders - known-type () known-types))) - (funcall methods-function contenders - (let ((k-t (make-list nreq))) - (dolist (index+type known-types) - (setf (nth (car index+type) k-t) - (cdr index+type))) - k-t)))) - (do-methods (p-tail contenders known-type winners known-types) - ;; CONTENDERS - ;; is a (sorted) list of methods that must be discriminated. - ;; KNOWN-TYPE - ;; is the type of this argument, constructed from tests - ;; already made. - ;; WINNERS - ;; is a (sorted) list of methods that are potentially - ;; applicable after the discrimination has been made. - (if (null contenders) - (do-column (cdr p-tail) - winners - (cons (cons (car p-tail) known-type) - known-types)) - (let* ((position (car p-tail)) - (method (car contenders)) - (specl (nth position (method-specializers method))) - (type (funcall type-function - (type-from-specializer specl)))) - (multiple-value-bind (app-p maybe-app-p) - (specializer-applicable-using-type-p type known-type) - (flet ((determined-to-be (truth-value) - (if truth-value app-p (not maybe-app-p))) - (do-if (truth &optional implied) - (let ((ntype (if truth type `(not ,type)))) - (do-methods p-tail - (cdr contenders) - (if implied - known-type - (augment-type ntype known-type)) - (if truth - (append winners `(,method)) - winners) - known-types)))) - (cond ((determined-to-be nil) (do-if nil t)) - ((determined-to-be t) (do-if t t)) - (t (funcall test-function position type - (do-if t) (do-if nil)))))))))) + (if p-tail + (let* ((position (car p-tail)) + (known-type (or (nth position types) t))) + (if (eq (nth position metatypes) t) + (do-column (cdr p-tail) contenders + (cons (cons position known-type) + known-types)) + (do-methods p-tail contenders + known-type () known-types))) + (funcall methods-function contenders + (let ((k-t (make-list nreq))) + (dolist (index+type known-types) + (setf (nth (car index+type) k-t) + (cdr index+type))) + k-t)))) + (do-methods (p-tail contenders known-type winners known-types) + ;; CONTENDERS + ;; is a (sorted) list of methods that must be discriminated. + ;; KNOWN-TYPE + ;; is the type of this argument, constructed from tests + ;; already made. + ;; WINNERS + ;; is a (sorted) list of methods that are potentially + ;; applicable after the discrimination has been made. + (if (null contenders) + (do-column (cdr p-tail) + winners + (cons (cons (car p-tail) known-type) + known-types)) + (let* ((position (car p-tail)) + (method (car contenders)) + (specl (nth position (method-specializers method))) + (type (funcall type-function + (type-from-specializer specl)))) + (multiple-value-bind (app-p maybe-app-p) + (specializer-applicable-using-type-p type known-type) + (flet ((determined-to-be (truth-value) + (if truth-value app-p (not maybe-app-p))) + (do-if (truth &optional implied) + (let ((ntype (if truth type `(not ,type)))) + (do-methods p-tail + (cdr contenders) + (if implied + known-type + (augment-type ntype known-type)) + (if truth + (append winners `(,method)) + winners) + known-types)))) + (cond ((determined-to-be nil) (do-if nil t)) + ((determined-to-be t) (do-if t t)) + (t (funcall test-fun position type + (do-if t) (do-if nil)))))))))) (do-column precedence methods ())))) (defun compute-secondary-dispatch-function (generic-function net &optional - method-alist wrappers) + method-alist wrappers) (function-funcall (compute-secondary-dispatch-function1 generic-function net) - method-alist wrappers)) + method-alist wrappers)) (defvar *eq-case-table-limit* 15) (defvar *case-table-limit* 10) (defun compute-mcase-parameters (case-list) - (unless (eq 't (caar (last case-list))) + (unless (eq t (caar (last case-list))) (error "The key for the last case arg to mcase was not T")) (let* ((eq-p (dolist (case case-list t) - (unless (or (eq (car case) 't) - (symbolp (caar case))) - (return nil)))) - (len (1- (length case-list))) - (type (cond ((= len 1) - :simple) - ((<= len - (if eq-p - *eq-case-table-limit* - *case-table-limit*)) - :assoc) - (t - :hash-table)))) + (unless (or (eq (car case) t) + (symbolp (caar case))) + (return nil)))) + (len (1- (length case-list))) + (type (cond ((= len 1) + :simple) + ((<= len + (if eq-p + *eq-case-table-limit* + *case-table-limit*)) + :assoc) + (t + :hash-table)))) (list eq-p type))) (defmacro mlookup (key info default &optional eq-p type) - (unless (or (eq eq-p 't) (null eq-p)) - (error "Invalid eq-p argument")) + (unless (or (eq eq-p t) (null eq-p)) + (bug "Invalid eq-p argument: ~S" eq-p)) (ecase type (:simple - `(if (,(if eq-p 'eq 'eql) ,key (car ,info)) - (cdr ,info) - ,default)) + `(if (locally + (declare (optimize (inhibit-warnings 3))) + (,(if eq-p 'eq 'eql) ,key (car ,info))) + (cdr ,info) + ,default)) (:assoc `(dolist (e ,info ,default) - (when (,(if eq-p 'eq 'eql) (car e) ,key) - (return (cdr e))))) + (when (locally + (declare (optimize (inhibit-warnings 3))) + (,(if eq-p 'eq 'eql) (car e) ,key)) + (return (cdr e))))) (:hash-table `(gethash ,key ,info ,default)))) @@ -1169,155 +1282,152 @@ (if (atom form) (default-test-converter form) (case (car form) - ((invoke-effective-method-function invoke-fast-method-call) - '.call.) - (methods - '.methods.) - (unordered-methods - '.umethods.) - (mcase - `(mlookup ,(cadr form) - nil - nil - ,@(compute-mcase-parameters (cddr form)))) - (t (default-test-converter form))))) + ((invoke-effective-method-function invoke-fast-method-call) + '.call.) + (methods + '.methods.) + (unordered-methods + '.umethods.) + (mcase + `(mlookup ,(cadr form) + nil + nil + ,@(compute-mcase-parameters (cddr form)))) + (t (default-test-converter form))))) (defun net-code-converter (form) (if (atom form) (default-code-converter form) (case (car form) - ((methods unordered-methods) - (let ((gensym (gensym))) - (values gensym - (list gensym)))) - (mcase - (let ((mp (compute-mcase-parameters (cddr form))) - (gensym (gensym)) (default (gensym))) - (values `(mlookup ,(cadr form) ,gensym ,default ,@mp) - (list gensym default)))) - (t - (default-code-converter form))))) + ((methods unordered-methods) + (let ((gensym (gensym))) + (values gensym + (list gensym)))) + (mcase + (let ((mp (compute-mcase-parameters (cddr form))) + (gensym (gensym)) (default (gensym))) + (values `(mlookup ,(cadr form) ,gensym ,default ,@mp) + (list gensym default)))) + (t + (default-code-converter form))))) (defun net-constant-converter (form generic-function) (or (let ((c (methods-converter form generic-function))) - (when c (list c))) + (when c (list c))) (if (atom form) - (default-constant-converter form) - (case (car form) - (mcase - (let* ((mp (compute-mcase-parameters (cddr form))) - (list (mapcar #'(lambda (clause) - (let ((key (car clause)) - (meth (cadr clause))) - (cons (if (consp key) (car key) key) - (methods-converter - meth generic-function)))) - (cddr form))) - (default (car (last list)))) - (list (list* ':mcase mp (nbutlast list)) - (cdr default)))) - (t - (default-constant-converter form)))))) + (default-constant-converter form) + (case (car form) + (mcase + (let* ((mp (compute-mcase-parameters (cddr form))) + (list (mapcar (lambda (clause) + (let ((key (car clause)) + (meth (cadr clause))) + (cons (if (consp key) (car key) key) + (methods-converter + meth generic-function)))) + (cddr form))) + (default (car (last list)))) + (list (list* :mcase mp (nbutlast list)) + (cdr default)))) + (t + (default-constant-converter form)))))) (defun methods-converter (form generic-function) (cond ((and (consp form) (eq (car form) 'methods)) - (cons '.methods. - (get-effective-method-function1 generic-function (cadr form)))) - ((and (consp form) (eq (car form) 'unordered-methods)) - (default-secondary-dispatch-function generic-function)))) + (cons '.methods. + (get-effective-method-function1 generic-function (cadr form)))) + ((and (consp form) (eq (car form) 'unordered-methods)) + (default-secondary-dispatch-function generic-function)))) (defun convert-methods (constant method-alist wrappers) (if (and (consp constant) - (eq (car constant) '.methods.)) + (eq (car constant) '.methods.)) (funcall (cdr constant) method-alist wrappers) constant)) (defun convert-table (constant method-alist wrappers) (cond ((and (consp constant) - (eq (car constant) ':mcase)) - (let ((alist (mapcar #'(lambda (k+m) - (cons (car k+m) - (convert-methods (cdr k+m) - method-alist - wrappers))) - (cddr constant))) - (mp (cadr constant))) - (ecase (cadr mp) - (:simple - (car alist)) - (:assoc - alist) - (:hash-table - (let ((table (make-hash-table :test (if (car mp) 'eq 'eql)))) - (dolist (k+m alist) - (setf (gethash (car k+m) table) (cdr k+m))) - table))))))) + (eq (car constant) :mcase)) + (let ((alist (mapcar (lambda (k+m) + (cons (car k+m) + (convert-methods (cdr k+m) + method-alist + wrappers))) + (cddr constant))) + (mp (cadr constant))) + (ecase (cadr mp) + (:simple + (car alist)) + (:assoc + alist) + (:hash-table + (let ((table (make-hash-table :test (if (car mp) 'eq 'eql)))) + (dolist (k+m alist) + (setf (gethash (car k+m) table) (cdr k+m))) + table))))))) (defun compute-secondary-dispatch-function1 (generic-function net - &optional function-p) + &optional function-p) (cond ((and (eq (car net) 'methods) (not function-p)) (get-effective-method-function1 generic-function (cadr net))) (t (let* ((name (generic-function-name generic-function)) - (arg-info (gf-arg-info generic-function)) - (metatypes (arg-info-metatypes arg-info)) - (applyp (arg-info-applyp arg-info)) - (fmc-arg-info (cons (length metatypes) applyp)) - (arglist (if function-p - (make-dfun-lambda-list metatypes applyp) - (make-fast-method-call-lambda-list metatypes applyp)))) + (arg-info (gf-arg-info generic-function)) + (metatypes (arg-info-metatypes arg-info)) + (applyp (arg-info-applyp arg-info)) + (fmc-arg-info (cons (length metatypes) applyp)) + (arglist (if function-p + (make-dfun-lambda-list metatypes applyp) + (make-fast-method-call-lambda-list metatypes applyp)))) (multiple-value-bind (cfunction constants) - (get-function1 `(,(if function-p - 'sb-kernel:instance-lambda - 'lambda) - ,arglist - ,@(unless function-p - `((declare (ignore .pv-cell. - .next-method-call.)))) - (locally (declare #.*optimize-speed*) - (let ((emf ,net)) - ,(make-emf-call metatypes applyp 'emf)))) - #'net-test-converter - #'net-code-converter - #'(lambda (form) - (net-constant-converter form generic-function))) - #'(lambda (method-alist wrappers) - (let* ((alist (list nil)) - (alist-tail alist)) - (dolist (constant constants) - (let* ((a (or (dolist (a alist nil) - (when (eq (car a) constant) - (return a))) - (cons constant - (or (convert-table - constant method-alist wrappers) - (convert-methods - constant method-alist wrappers))))) - (new (list a))) - (setf (cdr alist-tail) new) - (setf alist-tail new))) - (let ((function (apply cfunction (mapcar #'cdr (cdr alist))))) - (if function-p - function - (make-fast-method-call - :function (set-function-name function - `(sdfun-method ,name)) - :arg-info fmc-arg-info)))))))))) + (get-fun1 `(lambda + ,arglist + ,@(unless function-p + `((declare (ignore .pv-cell. + .next-method-call.)))) + (locally (declare #.*optimize-speed*) + (let ((emf ,net)) + ,(make-emf-call metatypes applyp 'emf)))) + #'net-test-converter + #'net-code-converter + (lambda (form) + (net-constant-converter form generic-function))) + (lambda (method-alist wrappers) + (let* ((alist (list nil)) + (alist-tail alist)) + (dolist (constant constants) + (let* ((a (or (dolist (a alist nil) + (when (eq (car a) constant) + (return a))) + (cons constant + (or (convert-table + constant method-alist wrappers) + (convert-methods + constant method-alist wrappers))))) + (new (list a))) + (setf (cdr alist-tail) new) + (setf alist-tail new))) + (let ((function (apply cfunction (mapcar #'cdr (cdr alist))))) + (if function-p + function + (make-fast-method-call + :function (set-fun-name function `(sdfun-method ,name)) + :arg-info fmc-arg-info)))))))))) (defvar *show-make-unordered-methods-emf-calls* nil) (defun make-unordered-methods-emf (generic-function methods) (when *show-make-unordered-methods-emf-calls* (format t "~&make-unordered-methods-emf ~S~%" - (generic-function-name generic-function))) - #'(lambda (&rest args) - (let* ((types (types-from-arguments generic-function args 'eql)) - (smethods (sort-applicable-methods generic-function - methods - types)) - (emf (get-effective-method-function generic-function smethods))) - (invoke-emf emf args)))) + (generic-function-name generic-function))) + (lambda (&rest args) + (let* ((types (types-from-args generic-function args 'eql)) + (smethods (sort-applicable-methods generic-function + methods + types)) + (emf (get-effective-method-function generic-function smethods))) + (invoke-emf emf args)))) ;;; The value returned by compute-discriminating-function is a function ;;; object. It is called a discriminating function because it is called @@ -1329,12 +1439,12 @@ ;;; the funcallable instance function of the generic function for which ;;; it was computed. ;;; -;;; More precisely, if compute-discriminating-function is called with an -;;; argument , and returns a result , that result must not be -;;; passed to apply or funcall directly. Rather, must be stored as -;;; the funcallable instance function of the same generic function -;;; (using set-funcallable-instance-function). Then the generic function -;;; can be passed to funcall or apply. +;;; More precisely, if compute-discriminating-function is called with +;;; an argument , and returns a result , that result must +;;; not be passed to apply or funcall directly. Rather, must be +;;; stored as the funcallable instance function of the same generic +;;; function (using SET-FUNCALLABLE-INSTANCE-FUNCTION). Then the +;;; generic function can be passed to funcall or apply. ;;; ;;; An important exception is that methods on this generic function are ;;; permitted to return a function which itself ends up calling the value @@ -1345,9 +1455,9 @@ ;;; ;;; (defmethod compute-discriminating-function ((gf my-generic-function)) ;;; (let ((std (call-next-method))) -;;; #'(lambda (arg) -;;; (print (list 'call-to-gf gf arg)) -;;; (funcall std arg)))) +;;; (lambda (arg) +;;; (print (list 'call-to-gf gf arg)) +;;; (funcall std arg)))) ;;; ;;; Because many discriminating functions would like to use a dynamic ;;; strategy in which the precise discriminating function changes with @@ -1372,30 +1482,30 @@ ;;; itself in accordance with this protocol: ;;; ;;; (defmethod compute-discriminating-function ((gf my-generic-function)) -;;; #'(lambda (arg) -;;; (cond ( -;;; -;;; (set-funcallable-instance-function -;;; gf -;;; (compute-discriminating-function gf)) -;;; (funcall gf arg)) -;;; (t -;;; )))) +;;; (lambda (arg) +;;; (cond ( +;;; +;;; (set-funcallable-instance-function +;;; gf +;;; (compute-discriminating-function gf)) +;;; (funcall gf arg)) +;;; (t +;;; )))) ;;; ;;; Whereas this code would not be legal: ;;; ;;; (defmethod compute-discriminating-function ((gf my-generic-function)) -;;; #'(lambda (arg) -;;; (cond ( -;;; (set-funcallable-instance-function -;;; gf -;;; #'(lambda (a) ..)) -;;; (funcall gf arg)) -;;; (t -;;; )))) +;;; (lambda (arg) +;;; (cond ( +;;; (set-funcallable-instance-function +;;; gf +;;; (lambda (a) ..)) +;;; (funcall gf arg)) +;;; (t +;;; )))) ;;; ;;; NOTE: All the examples above assume that all instances of the class -;;; my-generic-function accept only one argument. +;;; my-generic-function accept only one argument. (defun slot-value-using-class-dfun (class object slotd) (declare (ignore class)) @@ -1413,47 +1523,55 @@ (with-slots (dfun-state arg-info) gf (typecase dfun-state (null (let ((name (generic-function-name gf))) - (when (eq name 'compute-applicable-methods) - (update-all-c-a-m-gf-info gf)) - (cond ((eq name 'slot-value-using-class) - (update-slot-value-gf-info gf 'reader) - #'slot-value-using-class-dfun) - ((equal name '(setf slot-value-using-class)) - (update-slot-value-gf-info gf 'writer) - #'setf-slot-value-using-class-dfun) - ((eq name 'slot-boundp-using-class) - (update-slot-value-gf-info gf 'boundp) - #'slot-boundp-using-class-dfun) - ((gf-precompute-dfun-and-emf-p arg-info) - (make-final-dfun gf)) - (t - (make-initial-dfun gf))))) + (when (eq name 'compute-applicable-methods) + (update-all-c-a-m-gf-info gf)) + (cond ((eq name 'slot-value-using-class) + (update-slot-value-gf-info gf 'reader) + #'slot-value-using-class-dfun) + ((equal name '(setf slot-value-using-class)) + (update-slot-value-gf-info gf 'writer) + #'setf-slot-value-using-class-dfun) + ((eq name 'slot-boundp-using-class) + (update-slot-value-gf-info gf 'boundp) + #'slot-boundp-using-class-dfun) + ((gf-precompute-dfun-and-emf-p arg-info) + (make-final-dfun gf)) + (t + (make-initial-dfun gf))))) (function dfun-state) (cons (car dfun-state))))) (defmethod update-gf-dfun ((class std-class) gf) (let ((*new-class* class) - #|| (name (generic-function-name gf)) ||# - (arg-info (gf-arg-info gf))) + #|| (name (generic-function-name gf)) ||# + (arg-info (gf-arg-info gf))) (cond #|| - ((eq name 'slot-value-using-class) - (update-slot-value-gf-info gf 'reader)) - ((equal name '(setf slot-value-using-class)) - (update-slot-value-gf-info gf 'writer)) - ((eq name 'slot-boundp-using-class) - (update-slot-value-gf-info gf 'boundp)) - ||# - ((gf-precompute-dfun-and-emf-p arg-info) - (multiple-value-bind (dfun cache info) - (make-final-dfun-internal gf) - (set-dfun gf dfun cache info) ; lest the cache be freed twice - (update-dfun gf dfun cache info)))))) + ((eq name 'slot-value-using-class) + (update-slot-value-gf-info gf 'reader)) + ((equal name '(setf slot-value-using-class)) + (update-slot-value-gf-info gf 'writer)) + ((eq name 'slot-boundp-using-class) + (update-slot-value-gf-info gf 'boundp)) + ||# + ((gf-precompute-dfun-and-emf-p arg-info) + (multiple-value-bind (dfun cache info) + (make-final-dfun-internal gf) + (set-dfun gf dfun cache info) ; lest the cache be freed twice + (update-dfun gf dfun cache info)))))) + +(defun (setf class-name) (new-value class) + (let ((classoid (%wrapper-classoid (class-wrapper class)))) + (setf (classoid-name classoid) new-value)) + (reinitialize-instance class :name new-value)) + +(defun (setf generic-function-name) (new-value generic-function) + (reinitialize-instance generic-function :name new-value)) (defmethod function-keywords ((method standard-method)) (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) (analyze-lambda-list (if (consp method) - (early-method-lambda-list method) - (method-lambda-list method))) + (early-method-lambda-list method) + (method-lambda-list method))) (declare (ignore nreq nopt keysp restp)) (values keywords allow-other-keys-p))) @@ -1462,66 +1580,72 @@ (nreq nopt keysp restp allow-other-keys-p keywords keyword-parameters) (analyze-lambda-list ll) (declare (ignore nreq nopt keysp restp allow-other-keys-p keywords)) - (remove-if #'(lambda (s) - (or (memq s keyword-parameters) - (eq s '&allow-other-keys))) - ll))) + (remove-if (lambda (s) + (or (memq s keyword-parameters) + (eq s '&allow-other-keys))) + ll))) ;;; This is based on the rules of method lambda list congruency defined in ;;; the spec. The lambda list it constructs is the pretty union of the ;;; lambda lists of all the methods. It doesn't take method applicability ;;; into account at all yet. (defmethod generic-function-pretty-arglist - ((generic-function standard-generic-function)) - (let ((methods (generic-function-methods generic-function)) - (arglist ())) - (when methods - (multiple-value-bind (required optional rest key allow-other-keys) - (method-pretty-arglist (car methods)) - (dolist (m (cdr methods)) - (multiple-value-bind (method-key-keywords - method-allow-other-keys - method-key) - (function-keywords m) - ;; we've modified function-keywords to return what we want as - ;; the third value, no other change here. - (declare (ignore method-key-keywords)) - (setq key (union key method-key)) - (setq allow-other-keys (or allow-other-keys - method-allow-other-keys)))) - (when allow-other-keys - (setq arglist '(&allow-other-keys))) - (when key - (setq arglist (nconc (list '&key) key arglist))) - (when rest - (setq arglist (nconc (list '&rest rest) arglist))) - (when optional - (setq arglist (nconc (list '&optional) optional arglist))) - (nconc required arglist))))) + ((generic-function standard-generic-function)) + (let ((methods (generic-function-methods generic-function))) + (if methods + (let ((arglist ())) + ;; arglist is constructed from the GF's methods - maybe with + ;; keys and rest stuff added + (multiple-value-bind (required optional rest key allow-other-keys) + (method-pretty-arglist (car methods)) + (dolist (m (cdr methods)) + (multiple-value-bind (method-key-keywords + method-allow-other-keys + method-key) + (function-keywords m) + ;; we've modified function-keywords to return what we want as + ;; the third value, no other change here. + (declare (ignore method-key-keywords)) + (setq key (union key method-key)) + (setq allow-other-keys (or allow-other-keys + method-allow-other-keys)))) + (when allow-other-keys + (setq arglist '(&allow-other-keys))) + (when key + (setq arglist (nconc (list '&key) key arglist))) + (when rest + (setq arglist (nconc (list '&rest rest) arglist))) + (when optional + (setq arglist (nconc (list '&optional) optional arglist))) + (nconc required arglist))) + ;; otherwise we take the lambda-list from the GF directly, with no + ;; other 'keys' added ... + (let ((lambda-list (generic-function-lambda-list generic-function))) + lambda-list)))) (defmethod method-pretty-arglist ((method standard-method)) (let ((required ()) - (optional ()) - (rest nil) - (key ()) - (allow-other-keys nil) - (state 'required) - (arglist (method-lambda-list method))) + (optional ()) + (rest nil) + (key ()) + (allow-other-keys nil) + (state 'required) + (arglist (method-lambda-list method))) (dolist (arg arglist) - (cond ((eq arg '&optional) (setq state 'optional)) - ((eq arg '&rest) (setq state 'rest)) - ((eq arg '&key) (setq state 'key)) - ((eq arg '&allow-other-keys) (setq allow-other-keys 't)) - ((memq arg lambda-list-keywords)) - (t - (ecase state - (required (push arg required)) - (optional (push arg optional)) - (key (push arg key)) - (rest (setq rest arg)))))) + (cond ((eq arg '&optional) (setq state 'optional)) + ((eq arg '&rest) (setq state 'rest)) + ((eq arg '&key) (setq state 'key)) + ((eq arg '&allow-other-keys) (setq allow-other-keys t)) + ((memq arg lambda-list-keywords)) + (t + (ecase state + (required (push arg required)) + (optional (push arg optional)) + (key (push arg key)) + (rest (setq rest arg)))))) (values (nreverse required) - (nreverse optional) - rest - (nreverse key) - allow-other-keys))) + (nreverse optional) + rest + (nreverse key) + allow-other-keys)))