X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=2d63c9b108d39adc6ba5855c69f598439879a369;hb=6e9a41e3ec4205f3a6e02ba50ff36f4159a3dfd9;hp=f8f13a7b7230423c41581e0107451aceae51ce6b;hpb=c1d63b850fe9528036f8ae715088384e81d880cc;p=sbcl.git diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index f8f13a7..2d63c9b 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -220,8 +220,7 @@ specializers lambda-list &rest other-initargs) (unless (and (fboundp generic-function-name) (typep (fdefinition generic-function-name) 'generic-function)) - (style-warn "implicitly creating new generic function ~S" - generic-function-name)) + (warn 'implicit-generic-function-warning :name generic-function-name)) (let* ((existing-gf (find-generic-function generic-function-name nil)) (generic-function (if existing-gf @@ -266,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)))))) @@ -346,7 +345,7 @@ (let ((pos 0)) (dolist (type-spec (method-specializers method)) (unless (eq type-spec *the-class-t*) - (pushnew pos specialized-argument-positions)) + (pushnew pos specialized-argument-positions :test #'eq)) (incf pos))) ;; Finally merge the values for this method into the values ;; for the exisiting methods and return them. Note that if @@ -371,7 +370,7 @@ (defmethod generic-function-argument-precedence-order ((gf standard-generic-function)) - (aver (eq *boot-state* 'complete)) + (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) @@ -434,41 +433,71 @@ (list '(:sbcl :node "Metaobject Protocol") '(:amop :generic-function (setf slot-value-using-class))))) +(defgeneric values-for-add-method (gf method) + (:method ((gf standard-generic-function) (method standard-method)) + ;; KLUDGE: Just a single generic dispatch, and everything else + ;; comes from permutation vectors. Would be nicer to define + ;; REAL-ADD-METHOD with a proper method so that we could efficiently + ;; use SLOT-VALUE there. + ;; + ;; Optimization note: REAL-ADD-METHOD has a lot of O(N) stuff in it (as + ;; does PCL as a whole). It should not be too hard to internally store + ;; many of the things we now keep in lists as either purely functional + ;; O(log N) sets, or --if we don't mind the memory cost-- using + ;; specialized hash-tables: most things are used to answer questions about + ;; set-membership, not ordering. + (values (slot-value gf '%lock) + (slot-value method 'qualifiers) + (slot-value method 'specializers) + (slot-value method 'lambda-list) + (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) - (when (method-generic-function method) - (error "~@" - method (method-generic-function method))) - (flet ((similar-lambda-lists-p (method-a method-b) + (flet ((similar-lambda-lists-p (old-method new-lambda-list) (multiple-value-bind (a-nreq a-nopt a-keyp a-restp) - (analyze-lambda-list (method-lambda-list method-a)) + (analyze-lambda-list (method-lambda-list old-method)) (multiple-value-bind (b-nreq b-nopt b-keyp b-restp) - (analyze-lambda-list (method-lambda-list method-b)) + (analyze-lambda-list new-lambda-list) (and (= a-nreq b-nreq) (= a-nopt b-nopt) (eq (or a-keyp a-restp) (or b-keyp b-restp))))))) - (let ((lock (gf-lock generic-function))) - ;; HANDLER-CASE takes care of releasing the lock and enabling - ;; interrupts before going forth with the error. + (multiple-value-bind (lock qualifiers specializers new-lambda-list + 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 ;; inconsistent state. (sb-thread::with-recursive-system-spinlock (lock) - (let* ((qualifiers (method-qualifiers method)) - (specializers (method-specializers method)) - (existing (get-method generic-function - qualifiers - specializers - nil))) + (let ((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)) + (when (and existing (similar-lambda-lists-p existing new-lambda-list)) (remove-method generic-function existing)) ;; KLUDGE: We have a special case here, as we disallow @@ -482,7 +511,7 @@ (error 'new-value-specialization :method method)) (setf (method-generic-function method) generic-function) - (pushnew method (generic-function-methods generic-function)) + (pushnew method (generic-function-methods generic-function) :test #'eq) (dolist (specializer specializers) (add-direct-method specializer method)) @@ -531,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 @@ -558,11 +588,66 @@ :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.restp gf.rest + gf.keyp gf.keys gf.allowp) + (parse-lambda-list gf-lambda-list) + (declare (ignore gf.rest)) + ;; 7.6.4 point 5 probably entails that if any method says + ;; &allow-other-keys then the gf should be construed to + ;; accept any key. + (let ((allowp (or gf.allowp + (find '&allow-other-keys methods + :test #'find + :key #'method-lambda-list)))) + (setf (info :function :type name) + (specifier-type + `(function + (,@(mapcar tfun gf.required) + ,@(if gf.optional + `(&optional ,@(mapcar tfun gf.optional))) + ,@(if gf.restp + `(&rest t)) + ,@(when gf.keyp + (let ((all-keys + (mapcar + (lambda (x) + (list x t)) + (remove-duplicates + (nconc + (mapcan #'function-keywords methods) + (mapcar #'keywordicate gf.keys)))))) + (when all-keys + (setq keysp t) + `(&key ,@all-keys)))) + ,@(when (and (not keysp) allowp) + `(&key)) + ,@(when 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 @@ -590,7 +675,7 @@ (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) :test #'eq))))) (defun superclasses-compatible-p (class1 class2) (let ((cpl1 (cpl-or-nil class1)) @@ -698,7 +783,7 @@ (let ((emf (get-effective-method-function generic-function methods))) (invoke-emf emf args)) - (apply #'no-applicable-method generic-function args))))) + (call-no-applicable-method generic-function args))))) (defun list-eq (x y) (loop (when (atom x) (return (eq x y))) @@ -710,7 +795,7 @@ (defvar *std-cam-methods* nil) (defun compute-applicable-methods-emf (generic-function) - (if (eq *boot-state* 'complete) + (if (eq **boot-state** 'complete) (let* ((cam (gdefinition 'compute-applicable-methods)) (cam-methods (compute-applicable-methods-using-types cam (list `(eql ,generic-function) t)))) @@ -731,22 +816,23 @@ (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)) + (member old-method methods :test #'eq)) *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*) + (unless (member method *old-c-a-m-gf-methods* :test #'eq) (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))))) + (pushnew (specializer-object specl) gfs-to-do :test #'eq) + (pushnew (specializer-class specl) gf-classes-to-do :test #'eq))))) (map-all-generic-functions (lambda (gf) - (when (or (member gf gfs-to-do) + (when (or (member gf gfs-to-do :test #'eq) (dolist (class gf-classes-to-do nil) (member class - (class-precedence-list (class-of gf))))) + (class-precedence-list (class-of gf)) + :test #'eq))) (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))) @@ -817,8 +903,8 @@ (get-optimized-std-slot-value-using-class-method-function class slotd type)) (method-alist - `((,(car (or (member std-method methods) - (member str-method methods) + `((,(car (or (member std-method methods :test #'eq) + (member str-method methods :test #'eq) (bug "error in ~S" 'get-accessor-method-function))) ,optimized-std-fun))) @@ -1097,35 +1183,6 @@ (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)) - (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))) - 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) @@ -1499,44 +1556,74 @@ (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))))) - -(defmethod update-gf-dfun ((class std-class) gf) - (let ((*new-class* class) - (arg-info (gf-arg-info gf))) - (cond - ((special-case-for-compute-discriminating-function-p gf)) - ((gf-precompute-dfun-and-emf-p arg-info) - (multiple-value-bind (dfun cache info) - (make-final-dfun-internal gf) - (update-dfun gf dfun cache info)))))) +(let (initial-print-object-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 initial-print-object-cache nil) + (make-initial-dfun gf)) + (initial-print-object-cache + (multiple-value-bind (dfun cache info) + (make-caching-dfun gf (copy-cache initial-print-object-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 + (mapcar (lambda (x) (list (find-class x))) + '(sb-kernel::control-stack-exhausted + sb-kernel::binding-stack-exhausted + sb-kernel::alien-stack-exhausted + sb-kernel::heap-exhausted-error + restart))) + (setq initial-print-object-cache cache) + (set-dfun gf dfun (copy-cache 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 (setf class-name) (new-value class) (let ((classoid (wrapper-classoid (class-wrapper class)))) @@ -1550,6 +1637,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) + (analyze-lambda-list (if (consp method) + (early-method-lambda-list method) + (method-lambda-list method))) + (declare (ignore nreq nopt keysp restp)) + (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) @@ -1624,4 +1720,4 @@ (parse-lambda-list lambda-list) (declare (ignore restp keyp auxp aux morep)) (declare (ignore more-context more-count)) - (values required optional rest keys allowp))) \ No newline at end of file + (values required optional rest keys allowp)))