X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=efbd4822141e3cf7710124267939151af3a8ccaf;hb=4ba392170e98744f0ef0b8e08a5d42b988f1d0c9;hp=35f2c354fce1ec87d619f152df3f53d2c547fcb2;hpb=29193f72ababb585e5da518f98759f5d5f833957;p=sbcl.git diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 35f2c35..efbd482 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -370,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) @@ -487,7 +487,7 @@ ;; 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) + (sb-thread::with-recursive-system-lock (lock) (let ((existing (get-method generic-function qualifiers specializers @@ -554,12 +554,12 @@ (warn "~@" mc-name method qualifiers)))))) - (unless skip-dfun-update-p (update-ctors 'add-method :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,7 +574,7 @@ ;; 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) + (sb-thread::with-recursive-system-lock (lock) (let* ((specializers (method-specializers method)) (methods (generic-function-methods generic-function)) (new-methods (remove method methods))) @@ -587,11 +587,67 @@ :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))) + (ftype + (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 #'keyword-spec-name gf.keys)))))) + (when all-keys + (setq keysp t) + `(&key ,@all-keys)))) + ,@(when (and (not keysp) allowp) + `(&key)) + ,@(when allowp + `(&allow-other-keys))) + *)))) + (setf (info :function :type name) ftype + (info :function :where-from name) :defined-method + (gf-info-needs-update gf) nil) + ftype))))))) (defun compute-applicable-methods-function (generic-function arguments) (values (compute-applicable-methods-using-types @@ -727,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))) @@ -739,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)))) @@ -1127,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) @@ -1387,7 +1414,7 @@ (make-dfun-lambda-list nargs applyp) (make-fast-method-call-lambda-list nargs applyp)))) (multiple-value-bind (cfunction constants) - (get-fun1 `(lambda + (get-fun1 `(named-lambda (gf-dispatch ,name) ,arglist ,@(unless function-p `((declare (ignore .pv. .next-method-call.)))) @@ -1514,22 +1541,22 @@ (defun slot-value-using-class-dfun (class object slotd) (declare (ignore class)) - (function-funcall (slot-definition-reader-function slotd) object)) + (funcall (slot-info-reader (slot-definition-info slotd)) object)) (defun setf-slot-value-using-class-dfun (new-value class object slotd) (declare (ignore class)) - (function-funcall (slot-definition-writer-function slotd) new-value object)) + (funcall (slot-info-writer (slot-definition-info slotd)) new-value object)) (defun slot-boundp-using-class-dfun (class object slotd) (declare (ignore class)) - (function-funcall (slot-definition-boundp-function slotd) object)) + (funcall (slot-info-boundp (slot-definition-info slotd)) object)) (defun special-case-for-compute-discriminating-function-p (gf) (or (eq gf #'slot-value-using-class) (eq gf #'(setf slot-value-using-class)) (eq gf #'slot-boundp-using-class))) -(let (po-cache) +(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) @@ -1567,11 +1594,11 @@ (cond ((/= nkeys 1) ;; KLUDGE: someone has defined a method ;; specialized on the second argument: punt. - (setf po-cache nil) + (setf initial-print-object-cache nil) (make-initial-dfun gf)) - (po-cache + (initial-print-object-cache (multiple-value-bind (dfun cache info) - (make-caching-dfun gf po-cache) + (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 @@ -1583,27 +1610,20 @@ (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)))))) + (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 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)))))) (defmethod (setf class-name) (new-value class) (let ((classoid (wrapper-classoid (class-wrapper class)))) @@ -1619,11 +1639,11 @@ (defmethod function-keywords ((method standard-method)) (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p - keywords keyword-parameters) + keywords) (analyze-lambda-list (if (consp method) (early-method-lambda-list method) (method-lambda-list method))) - (declare (ignore nreq nopt keysp restp keywords)) + (declare (ignore nreq nopt keysp restp)) (values keywords allow-other-keys-p))) (defmethod function-keyword-parameters ((method standard-method)) @@ -1697,7 +1717,7 @@ ;; PARSE-LAMBDA-LIST to something handier. (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux morep more-context more-count) - (parse-lambda-list lambda-list) + (parse-lambda-list lambda-list :silent t) (declare (ignore restp keyp auxp aux morep)) (declare (ignore more-context more-count)) (values required optional rest keys allowp)))