X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=79ac11b3113a4e27cc4e853145f2c43d39efc79a;hb=28b2447f2775779fe49fd024d8cce069060431c6;hp=d2e5d9c7429f5a8bd3e1c0705e0846428ce7b34b;hpb=4c64e9aed42b9041e6eb1f81ff335aa7ff7da506;p=sbcl.git diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index d2e5d9c..79ac11b 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -265,7 +265,7 @@ (dolist (method methods) (let ((mspecializers (method-specializers method))) (aver (= lspec (length mspecializers))) - (when (and (equal qualifiers (method-qualifiers method)) + (when (and (equal qualifiers (safe-method-qualifiers method)) (every #'same-specializer-p specializers (method-specializers method))) (return method)))))) @@ -450,7 +450,18 @@ (slot-value method 'qualifiers) (slot-value method 'specializers) (slot-value method 'lambda-list) - (slot-value method '%generic-function)))) + (slot-value method '%generic-function) + (slot-value gf 'name)))) + +(define-condition print-object-stream-specializer (reference-condition simple-warning) + () + (:default-initargs + :references (list '(:ansi-cl :function print-object)) + :format-control "~@" + :format-arguments (list 'print-object))) (defun real-add-method (generic-function method &optional skip-dfun-update-p) (flet ((similar-lambda-lists-p (old-method new-lambda-list) @@ -463,13 +474,15 @@ (eq (or a-keyp a-restp) (or b-keyp b-restp))))))) (multiple-value-bind (lock qualifiers specializers new-lambda-list - method-gf) + method-gf name) (values-for-add-method generic-function method) (when method-gf (error "~@" method method-gf)) + (when (and (eq name 'print-object) (not (eq (second specializers) *the-class-t*))) + (warn 'print-object-stream-specializer)) (handler-case ;; System lock because interrupts need to be disabled as ;; well: it would be bad to unwind and leave the gf in an @@ -547,6 +560,7 @@ :generic-function generic-function :method method) (update-dfun generic-function)) + (setf (gf-info-needs-update generic-function) t) (map-dependents generic-function (lambda (dep) (update-dependent generic-function @@ -574,11 +588,54 @@ :generic-function generic-function :method method) (update-dfun generic-function) + (setf (gf-info-needs-update generic-function) t) (map-dependents generic-function (lambda (dep) (update-dependent generic-function dep 'remove-method method))))))) generic-function) + + +;; Tell INFO about the generic function's methods' keys so that the +;; compiler doesn't complain that the keys defined for some method are +;; unrecognized. +(sb-ext:without-package-locks + (defun sb-c::maybe-update-info-for-gf (name) + (let ((gf (if (fboundp name) (fdefinition name)))) + (when (and gf (generic-function-p gf) (not (early-gf-p gf)) + (not (eq :declared (info :function :where-from name))) + (gf-info-needs-update gf)) + (let* ((methods (generic-function-methods gf)) + (gf-lambda-list (generic-function-lambda-list gf)) + (tfun (constantly t)) + keysp) + (multiple-value-bind + (gf.required gf.optional gf.rest ignore gf.allowp) + (%split-arglist gf-lambda-list) + (declare (ignore ignore)) + (setf (info :function :type name) + (specifier-type + `(function + (,@(mapcar tfun gf.required) + ,@(if gf.optional + `(&optional ,@(mapcar tfun gf.optional))) + ,@(if gf.rest + `(&rest t)) + ,@(let ((all-keys + (mapcar + (lambda (x) + (list x t)) + (remove-duplicates + (mapcan #'function-keywords methods))))) + (when all-keys + (setq keysp t) + `(&key ,@all-keys))) + ,@(if (and keysp gf.allowp) + `(&allow-other-keys))) + *)) + (info :function :where-from name) :defined-method + (gf-info-needs-update gf) nil))))) + (values))) (defun compute-applicable-methods-function (generic-function arguments) (values (compute-applicable-methods-using-types @@ -1516,34 +1573,71 @@ (eq gf #'(setf slot-value-using-class)) (eq gf #'slot-boundp-using-class))) -(defmethod compute-discriminating-function ((gf standard-generic-function)) - (let ((dfun-state (slot-value gf 'dfun-state))) - (when (special-case-for-compute-discriminating-function-p gf) - ;; if we have a special case for - ;; COMPUTE-DISCRIMINATING-FUNCTION, then (at least for the - ;; special cases implemented as of 2006-05-09) any information - ;; in the cache is misplaced. - (aver (null dfun-state))) - (typecase dfun-state - (null - (when (eq gf #'compute-applicable-methods) - (update-all-c-a-m-gf-info gf)) - (cond - ((eq gf #'slot-value-using-class) - (update-slot-value-gf-info gf 'reader) - #'slot-value-using-class-dfun) - ((eq gf #'(setf slot-value-using-class)) - (update-slot-value-gf-info gf 'writer) - #'setf-slot-value-using-class-dfun) - ((eq gf #'slot-boundp-using-class) - (update-slot-value-gf-info gf 'boundp) - #'slot-boundp-using-class-dfun) - ((gf-precompute-dfun-and-emf-p (slot-value gf 'arg-info)) - (make-final-dfun gf)) - (t - (make-initial-dfun gf)))) - (function dfun-state) - (cons (car dfun-state))))) +(let (po-cache) + (defmethod compute-discriminating-function ((gf standard-generic-function)) + (let ((dfun-state (slot-value gf 'dfun-state))) + (when (special-case-for-compute-discriminating-function-p gf) + ;; if we have a special case for + ;; COMPUTE-DISCRIMINATING-FUNCTION, then (at least for the + ;; special cases implemented as of 2006-05-09) any information + ;; in the cache is misplaced. + (aver (null dfun-state))) + (typecase dfun-state + (null + (when (eq gf #'compute-applicable-methods) + (update-all-c-a-m-gf-info gf)) + (cond + ((eq gf #'slot-value-using-class) + (update-slot-value-gf-info gf 'reader) + #'slot-value-using-class-dfun) + ((eq gf #'(setf slot-value-using-class)) + (update-slot-value-gf-info gf 'writer) + #'setf-slot-value-using-class-dfun) + ((eq gf #'slot-boundp-using-class) + (update-slot-value-gf-info gf 'boundp) + #'slot-boundp-using-class-dfun) + ;; KLUDGE: PRINT-OBJECT is not a special-case in the sense + ;; of having a desperately special discriminating function. + ;; However, it is important that the machinery for printing + ;; conditions for stack and heap exhaustion, and the + ;; restarts offered by the debugger, work without consuming + ;; many extra resources. This way (testing by name of GF + ;; rather than by identity) was the only way I found to get + ;; this to bootstrap, given that the PRINT-OBJECT generic + ;; function is only set up later, in + ;; SRC;PCL;PRINT-OBJECT.LISP. -- CSR, 2008-06-09 + ((eq (slot-value gf 'name) 'print-object) + (let ((nkeys (nth-value 3 (get-generic-fun-info gf)))) + (cond ((/= nkeys 1) + ;; KLUDGE: someone has defined a method + ;; specialized on the second argument: punt. + (setf po-cache nil) + (make-initial-dfun gf)) + (po-cache + (multiple-value-bind (dfun cache info) + (make-caching-dfun gf po-cache) + (set-dfun gf dfun cache info))) + ;; the relevant PRINT-OBJECT methods get defined + ;; late, by delayed DEF!METHOD. We mustn't cache + ;; the effective method for our classes earlier + ;; than the relevant PRINT-OBJECT methods are + ;; defined... + ((boundp 'sb-impl::*delayed-def!method-args*) + (make-initial-dfun gf)) + (t (multiple-value-bind (dfun cache info) + (make-final-dfun-internal + gf + (list (list (find-class 'sb-kernel::control-stack-exhausted)) + (list (find-class 'sb-kernel::heap-exhausted-error)) + (list (find-class 'restart)))) + (setq po-cache cache) + (set-dfun gf dfun cache info)))))) + ((gf-precompute-dfun-and-emf-p (slot-value gf '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) @@ -1567,6 +1661,15 @@ (reinitialize-instance generic-function :name new-value) new-value) +(defmethod function-keywords ((method standard-method)) + (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p + keywords keyword-parameters) + (analyze-lambda-list (if (consp method) + (early-method-lambda-list method) + (method-lambda-list method))) + (declare (ignore nreq nopt keysp restp keywords)) + (values keywords allow-other-keys-p))) + (defmethod function-keyword-parameters ((method standard-method)) (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords keyword-parameters)