X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=20158c0fc3b8b9a86f68dc32139b2337140b8d24;hb=ff92598854bf7cae8d57fe49cef4d9a98e1ab345;hp=8d5b2f06844aca93d7156616131434ff457a224d;hpb=1e08b23e730c7a1c9cda1b918e9fdca38b8c4e17;p=sbcl.git diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 8d5b2f0..20158c0 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -89,10 +89,7 @@ "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") + (cond ((not (symbolp x)) "is not a symbol") (t t))) (defmethod legal-specializers-p ((object standard-method) x) @@ -266,30 +263,7 @@ (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 - (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 @@ -297,8 +271,8 @@ &rest other-initargs) (unless (and (fboundp generic-function-name) (typep (fdefinition generic-function-name) 'generic-function)) - (sb-kernel::style-warn "implicitly creating new generic function ~S" - generic-function-name)) + (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? @@ -311,28 +285,60 @@ :specializers specs :lambda-list lambda-list other-initargs))) - (add-method generic-function new))) + (add-method generic-function new) + new)) + +(define-condition find-method-length-mismatch + (reference-condition simple-error) + () + (:default-initargs :references '(: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)) - (let ((mspecializers (method-specializers method))) - (when (and (equal qualifiers (method-qualifiers method)) - (= (length specializers) (length mspecializers)) - (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)) + ;; 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 @@ -399,11 +405,14 @@ (defun make-discriminating-function-arglist (number-required-arguments restp) (nconc (let ((args nil)) (dotimes (i number-required-arguments) - (push (intern (format nil "Discriminating Function Arg ~D" i)) + (push (format-symbol *package* ;; ! is this right? + "Discriminating Function Arg ~D" + i) args)) (nreverse args)) (when restp - `(&rest ,(intern "Discriminating Function &rest Arg"))))) + `(&rest ,(format-symbol *package* + "Discriminating Function &rest Arg"))))) (defmethod generic-function-argument-precedence-order ((gf standard-generic-function)) @@ -422,8 +431,7 @@ (defmethod initialize-instance :after ((gf standard-generic-function) &key (lambda-list nil lambda-list-p) argument-precedence-order) - (with-slots (arg-info) - gf + (with-slots (arg-info) gf (if lambda-list-p (set-arg-info gf :lambda-list lambda-list @@ -432,25 +440,25 @@ (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 (and (arg-info-valid-p (gf-arg-info gf)) + (not (null args)) + (or lambda-list-p (cddr args))) + (update-dfun gf))))) (declaim (special *lazy-dfun-compute-p*)) @@ -461,9 +469,9 @@ (defun real-add-method (generic-function method &optional skip-dfun-update-p) (when (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." + (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) @@ -507,20 +515,46 @@ (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)) - 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)) + (let* ((name (generic-function-name generic-function)) (specializers (method-specializers method)) - (methods (generic-function-methods generic-function)) - (new-methods (remove method methods))) + (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)) @@ -529,8 +563,8 @@ (update-ctors 'remove-method :generic-function generic-function :method method) - (update-dfun generic-function) - generic-function))) + (update-dfun generic-function))) + generic-function) (defun compute-applicable-methods-function (generic-function arguments) (values (compute-applicable-methods-using-types @@ -561,8 +595,8 @@ (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) @@ -653,9 +687,10 @@ (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))))) + (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 @@ -758,6 +793,22 @@ *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)) @@ -768,27 +819,25 @@ (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)) + (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) @@ -807,6 +856,9 @@ (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) @@ -823,6 +875,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*) @@ -841,17 +905,18 @@ (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) + (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) + ((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))))))) @@ -916,7 +981,7 @@ ((eq valuep :constant-value) (value-for-caching generic-function classes))))) - (setq cache (fill-cache cache wrappers value t)))))))) + (setq cache (fill-cache cache wrappers value)))))))) (if classes-list (mapc #'add-class-list classes-list) (dolist (method (generic-function-methods generic-function)) @@ -929,7 +994,8 @@ (cond ((eq class *the-class-t*) t) ((eq class *the-class-slot-object*) - `(not (cl:typep (cl:class-of ,arg) 'cl:built-in-class))) + `(not (typep (classoid-of ,arg) + 'built-in-classoid))) ((eq class *the-class-std-object*) `(or (std-instance-p ,arg) (fsc-instance-p ,arg))) ((eq class *the-class-standard-object*) @@ -1168,15 +1234,19 @@ (defmacro mlookup (key info default &optional eq-p type) (unless (or (eq eq-p t) (null eq-p)) - (error "Invalid eq-p argument")) + (bug "Invalid eq-p argument: ~S" eq-p)) (ecase type (:simple - `(if (,(if eq-p 'eq 'eql) ,key (car ,info)) + `(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) + (when (locally + (declare (optimize (inhibit-warnings 3))) + (,(if eq-p 'eq 'eql) (car e) ,key)) (return (cdr e))))) (:hash-table `(gethash ,key ,info ,default)))) @@ -1285,7 +1355,7 @@ (make-fast-method-call-lambda-list metatypes applyp)))) (multiple-value-bind (cfunction constants) (get-fun1 `(,(if function-p - 'sb-kernel:instance-lambda + 'instance-lambda 'lambda) ,arglist ,@(unless function-p @@ -1344,12 +1414,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-fun). 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 @@ -1390,7 +1460,7 @@ ;;; (lambda (arg) ;;; (cond ( ;;; -;;; (set-funcallable-instance-fun +;;; (set-funcallable-instance-function ;;; gf ;;; (compute-discriminating-function gf)) ;;; (funcall gf arg)) @@ -1402,7 +1472,7 @@ ;;; (defmethod compute-discriminating-function ((gf my-generic-function)) ;;; (lambda (arg) ;;; (cond ( -;;; (set-funcallable-instance-fun +;;; (set-funcallable-instance-function ;;; gf ;;; (lambda (a) ..)) ;;; (funcall gf arg)) @@ -1464,6 +1534,10 @@ (set-dfun gf dfun cache info) ; lest the cache be freed twice (update-dfun gf dfun cache info)))))) +(defmethod (setf class-name) :before (new-value (class class)) + (let ((classoid (find-classoid (class-name class)))) + (setf (classoid-name classoid) 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)