X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=7efb80d5313c94e8aaf2e2a9bd5cf33cb9e191e8;hb=b56c1a4dc22aa0ac827343667584aa6090b15f02;hp=f61386ebd82d77dabc8e3b95651f5d7aa76d037a;hpb=e404d36bb823d93ad20ccd6c653244cf443f2633;p=sbcl.git diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index f61386e..7efb80d 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -23,29 +23,13 @@ (in-package "SB-PCL") - ;;; methods ;;; ;;; Methods themselves are simple inanimate objects. Most properties of ;;; methods are immutable, methods cannot be reinitialized. The following ;;; properties of methods can be changed: ;;; METHOD-GENERIC-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))))) - -(defmethod accessor-method-class ((method standard-accessor-method)) - (car (slot-value method 'specializers))) - -(defmethod accessor-method-class ((method standard-writer-method)) - (cadr (slot-value method 'specializers))) - + ;;; initialization ;;; ;;; Error checking is done in before methods. Because of the simplicity of @@ -78,127 +62,99 @@ (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)) - t - "a string or NULL")) - -(defmethod legal-lambda-list-p ((object standard-method) x) - (declare (ignore x)) - t) +(define-condition invalid-method-initarg (simple-program-error) + ((method :initarg :method :reader invalid-method-initarg-method)) + (:report + (lambda (c s) + (format s "~@" + (invalid-method-initarg-method c) + (simple-condition-format-control c) + (simple-condition-format-arguments c))))) + +(defun invalid-method-initarg (method format-control &rest args) + (error 'invalid-method-initarg :method method + :format-control format-control :format-arguments args)) + +(defun check-documentation (method doc) + (unless (or (null doc) (stringp doc)) + (invalid-method-initarg method "~@<~S of ~S is neither ~S nor a ~S.~@:>" + :documentation doc 'null 'string))) +(defun check-lambda-list (method ll) + nil) -(defmethod legal-method-function-p ((object standard-method) x) - (if (functionp x) - t - "a function")) +(defun check-method-function (method fun) + (unless (functionp fun) + (invalid-method-initarg method "~@<~S of ~S is not a ~S.~@:>" + :function fun 'function))) -(defmethod legal-qualifiers-p ((object standard-method) x) +(defun check-qualifiers (method qualifiers) (flet ((improper-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))))) - t)) - -(defmethod legal-qualifier-p ((object standard-method) x) - (if (and x (atom x)) - t - "is not a non-null atom")) - -(defmethod legal-slot-name-p ((object standard-method) x) - (cond ((not (symbolp x)) "is not a symbol") - (t t))) - -(defmethod legal-specializers-p ((object standard-method) x) + (invalid-method-initarg method + "~@<~S of ~S is an improper list.~@:>" + :qualifiers qualifiers))) + (dolist-carefully (q qualifiers improper-list) + (unless (and q (atom q)) + (invalid-method-initarg method + "~@<~S, in ~S ~S, is not a non-~S atom.~@:>" + q :qualifiers qualifiers 'null))))) + +(defun check-slot-name (method name) + (unless (symbolp name) + (invalid-method-initarg "~@<~S of ~S is not a ~S.~@:>" + :slot-name name 'symbol))) + +(defun check-specializers (method specializers) (flet ((improper-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))))) - 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))) - 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) + (invalid-method-initarg method + "~@<~S of ~S is an improper list.~@:>" + :specializers specializers))) + (dolist-carefully (s specializers improper-list) + (unless (specializerp s) + (invalid-method-initarg method + "~@<~S, in ~S ~S, is not a ~S.~@:>" + s :specializers specializers 'specializer))) + ;; KLUDGE: ANSI says that it's not valid to have methods + ;; specializing on classes which are "not defined", leaving + ;; unclear what the definedness of a class is; AMOP suggests that + ;; forward-referenced-classes, since they have proper names and + ;; all, are at least worthy of some level of definition. We allow + ;; methods specialized on forward-referenced-classes, but it's + ;; non-portable and potentially dubious, so + (let ((frcs (remove-if-not #'forward-referenced-class-p specializers))) + (unless (null frcs) + (style-warn "~@" + (length frcs) frcs))))) + +(defmethod shared-initialize :before + ((method standard-method) slot-names &key + qualifiers lambda-list specializers 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))) - (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-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)) - (unless (eq check-lambda-list t) - (lose :lambda-list lambda-list check-lambda-list)) - (unless (eq check-specializers t) - (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))))) - -(defmethod shared-initialize :before ((method standard-accessor-method) - slot-names - &key slot-name slot-definition) + ;; FIXME: it's not clear to me (CSR, 2006-08-09) why methods get + ;; this extra paranoia and nothing else does; either everything + ;; should be aggressively checking initargs, or nothing much should. + ;; In either case, it would probably be better to have :type + ;; declarations in slots, which would then give a suitable type + ;; error (if we implement type-checking for slots...) rather than + ;; this hand-crafted thing. + (check-qualifiers method qualifiers) + (check-lambda-list method lambda-list) + (check-specializers method specializers) + (check-method-function method function) + (check-documentation method documentation)) + +(defmethod shared-initialize :before + ((method standard-accessor-method) 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))))) + (check-slot-name method slot-name))) (defmethod shared-initialize :after ((method standard-method) slot-names - &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)))) - -(defmethod shared-initialize :after ((method standard-accessor-method) - 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 (and %slot-definition (null slot-name)) - (setq slot-name (slot-definition-name %slot-definition))))) - -(defmethod method-qualifiers ((method standard-method)) - (plist-value method 'qualifiers)) + &rest initargs &key ((method-cell method-cell))) + (declare (ignore slot-names method-cell)) + (initialize-method-function initargs method)) (defvar *the-class-generic-function* (find-class 'generic-function)) @@ -252,59 +208,35 @@ (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) - (declare (ignore documentation declarations argument-precedence-order - 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)))) -; (add-initarg name :name 'name) -; (add-initarg lambda-list :lambda-list 'lambda-list) -; (add-initarg 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) -; (add-initarg method-combination :method-combination '%method-combination) - (apply #'call-next-method generic-function initargs))) -||# -;;; These two are scheduled for demolition. -(defun real-add-named-method (generic-function-name - qualifiers - specializers - lambda-list - &rest other-initargs) +(defun find-generic-function (name &optional (errorp t)) + (let ((fun (and (fboundp name) (fdefinition name)))) + (cond + ((and fun (typep fun 'generic-function)) fun) + (errorp (error "No generic function named ~S." name)) + (t nil)))) + +(defun real-add-named-method (generic-function-name qualifiers + 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)) - ;; 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) - new)) + (warn 'implicit-generic-function-warning :name generic-function-name)) + (let* ((existing-gf (find-generic-function generic-function-name nil)) + (generic-function + (if existing-gf + (ensure-generic-function + generic-function-name + :generic-function-class (class-of existing-gf)) + (ensure-generic-function generic-function-name))) + (proto (method-prototype-for-gf generic-function-name))) + ;; FIXME: Destructive modification of &REST list. + (setf (getf (getf other-initargs 'plist) :name) + (make-method-spec generic-function qualifiers specializers)) + (let ((new (apply #'make-instance (class-of proto) + :qualifiers qualifiers :specializers specializers + :lambda-list lambda-list other-initargs))) + (add-method generic-function new) + new))) (define-condition find-method-length-mismatch (reference-condition simple-error) @@ -333,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)))))) @@ -353,11 +285,14 @@ ;; 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)) + (real-get-method + generic-function qualifiers + ;; ANSI for FIND-METHOD seems to imply that in fact specializers + ;; should always be passed in parsed form instead of being parsed + ;; at this point. Since there's no ANSI-blessed way of getting an + ;; EQL specializer, that seems unnecessarily painful, so we are + ;; nice to our users. -- CSR, 2007-06-01 + (parse-specializers generic-function 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 @@ -410,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 @@ -435,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) @@ -498,123 +433,221 @@ (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* ((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 (and existing (similar-lambda-lists-p existing method)) - (remove-method generic-function existing)) - - ;; KLUDGE: We have a special case here, as we disallow - ;; specializations of the NEW-VALUE argument to (SETF - ;; SLOT-VALUE-USING-CLASS). GET-ACCESSOR-METHOD-FUNCTION is - ;; the optimizing function here: it precomputes the effective - ;; method, assuming that there is no dispatch to be done on - ;; the new-value argument. - (when (and (eq generic-function #'(setf slot-value-using-class)) - (not (eq *the-class-t* (first specializers)))) - (error 'new-value-specialization - :method method)) - - (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-name 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))) + (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-lock (lock) + (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 new-lambda-list)) + (remove-method generic-function existing)) + + ;; KLUDGE: We have a special case here, as we disallow + ;; specializations of the NEW-VALUE argument to (SETF + ;; SLOT-VALUE-USING-CLASS). GET-ACCESSOR-METHOD-FUNCTION is + ;; the optimizing function here: it precomputes the effective + ;; method, assuming that there is no dispatch to be done on + ;; the new-value argument. + (when (and (eq generic-function #'(setf slot-value-using-class)) + (not (eq *the-class-t* (first specializers)))) + (error 'new-value-specialization :method method)) + + (setf (method-generic-function method) generic-function) + (pushnew method (generic-function-methods generic-function) :test #'eq) + (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-name 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)) + (setf (gf-info-needs-update generic-function) t) + (map-dependents generic-function + (lambda (dep) + (update-dependent generic-function + dep 'add-method method))))) + (serious-condition (c) + (error c))))) + generic-function) (defun real-remove-method (generic-function method) (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))) - (setf (method-generic-function method) nil) - (setf (generic-function-methods generic-function) new-methods) - (dolist (specializer (method-specializers method)) - (remove-direct-method specializer method)) - (set-arg-info generic-function) - (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))))) + (let ((lock (gf-lock generic-function))) + ;; 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-lock (lock) + (let* ((specializers (method-specializers method)) + (methods (generic-function-methods generic-function)) + (new-methods (remove method methods))) + (setf (method-generic-function method) nil + (generic-function-methods generic-function) new-methods) + (dolist (specializer (method-specializers method)) + (remove-direct-method specializer method)) + (set-arg-info generic-function) + (update-ctors 'remove-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 + 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 #'keywordicate 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 @@ -642,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)) @@ -673,7 +706,7 @@ )) (defmethod same-specializer-p ((specl1 specializer) (specl2 specializer)) - nil) + (eql specl1 specl2)) (defmethod same-specializer-p ((specl1 class) (specl2 class)) (eq specl1 specl2)) @@ -692,14 +725,9 @@ (defmethod specializer-class ((specializer eql-specializer)) (class-of (slot-value specializer 'object))) -(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)))) - +(defun specializer-class-or-nil (specializer) + (and (standard-specializer-p specializer) + (specializer-class specializer))) (defun error-need-at-least-n-args (function n) (error 'simple-program-error @@ -746,9 +774,7 @@ (defun value-for-caching (gf classes) (let ((methods (compute-applicable-methods-using-types gf (mapcar #'class-eq-type classes)))) - (method-function-get (or (safe-method-fast-function (car methods)) - (safe-method-function (car methods))) - :constant-value))) + (method-plist-value (car methods) :constant-value))) (defun default-secondary-dispatch-function (generic-function) (lambda (&rest args) @@ -757,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))) @@ -769,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)))) @@ -790,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))) @@ -827,16 +854,17 @@ (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))))) + (type + (and class + (cond ((or (eq class *the-class-standard-reader-method*) + (eq class *the-class-global-reader-method*)) + 'reader) + ((or (eq class *the-class-standard-writer-method*) + (eq class *the-class-global-writer-method*)) + 'writer) + ((or (eq class *the-class-standard-boundp-method*) + (eq class *the-class-global-boundp-method*)) + 'boundp))))) (when (and (gf-info-c-a-m-emf-std-p arg-info) type (dolist (method (cdr methods) t) @@ -875,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))) @@ -897,13 +925,13 @@ (unless *new-class* (update-std-or-str-methods gf type)) (when (and (standard-svuc-method type) (structure-svuc-method type)) - (flet ((update-class (class) + (flet ((update-accessor-info (class) (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-accessor-info *new-class*) + (map-all-classes #'update-accessor-info 'slot-object))))) (defvar *standard-slot-value-using-class-method* nil) (defvar *standard-setf-slot-value-using-class-method* nil) @@ -974,19 +1002,20 @@ (set-structure-svuc-method type method))))))) (defun mec-all-classes-internal (spec precompute-p) - (unless (invalid-wrapper-p (class-wrapper (specializer-class spec))) - (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-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))))))) + (let ((wrapper (class-wrapper (specializer-class spec)))) + (unless (or (not wrapper) (invalid-wrapper-p wrapper)) + (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-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))) @@ -1019,21 +1048,28 @@ (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))) + (precompute-p (gf-precompute-dfun-and-emf-p arg-info))) (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 ((%wrappers (get-wrappers-from-classes + nkeys wrappers classes metatypes))) + (when (and %wrappers (not (probe-cache cache %wrappers))) (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)))))))) + ;; need to get them again, as finalization might + ;; have happened in between, which would + ;; invalidate wrappers. + (let ((wrappers (get-wrappers-from-classes + nkeys wrappers classes metatypes))) + (when (if (atom wrappers) + (not (invalid-wrapper-p wrappers)) + (every (complement #'invalid-wrapper-p) + wrappers)) + (setq cache (fill-cache cache wrappers value)))))))))) (if classes-list (mapc #'add-class-list classes-list) (dolist (method (generic-function-methods generic-function)) @@ -1147,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) @@ -1306,7 +1313,8 @@ (if (atom form) (default-test-converter form) (case (car form) - ((invoke-effective-method-function invoke-fast-method-call) + ((invoke-effective-method-function invoke-fast-method-call + invoke-effective-narrow-method-function) '.call.) (methods '.methods.) @@ -1399,20 +1407,20 @@ (let* ((name (generic-function-name generic-function)) (arg-info (gf-arg-info generic-function)) (metatypes (arg-info-metatypes arg-info)) + (nargs (length metatypes)) (applyp (arg-info-applyp arg-info)) - (fmc-arg-info (cons (length metatypes) applyp)) + (fmc-arg-info (cons nargs applyp)) (arglist (if function-p - (make-dfun-lambda-list metatypes applyp) - (make-fast-method-call-lambda-list metatypes applyp)))) + (make-dfun-lambda-list nargs applyp) + (make-fast-method-call-lambda-list nargs applyp)))) (multiple-value-bind (cfunction constants) (get-fun1 `(lambda ,arglist ,@(unless function-p - `((declare (ignore .pv-cell. - .next-method-call.)))) + `((declare (ignore .pv. .next-method-call.)))) (locally (declare #.*optimize-speed*) (let ((emf ,net)) - ,(make-emf-call metatypes applyp 'emf)))) + ,(make-emf-call nargs applyp 'emf)))) #'net-test-converter #'net-code-converter (lambda (form) @@ -1533,64 +1541,95 @@ (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))) -(defmethod compute-discriminating-function ((gf standard-generic-function)) - (with-slots (dfun-state arg-info) gf - (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 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) - (set-dfun gf dfun cache info) ; lest the cache be freed twice - (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)))) - (setf (classoid-name classoid) new-value)) + (let ((classoid (wrapper-classoid (class-wrapper class)))) + (if (and new-value (symbolp new-value)) + (setf (classoid-name classoid) new-value) + (setf (classoid-name classoid) nil))) (reinitialize-instance class :name new-value) new-value) @@ -1599,13 +1638,23 @@ new-value) (defmethod function-keywords ((method standard-method)) - (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) + (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) + (analyze-lambda-list (if (consp method) + (early-method-lambda-list method) + (method-lambda-list method))) + (declare (ignore nreq nopt keysp restp keywords)) + (values keyword-parameters allow-other-keys-p))) + (defun method-ll->generic-function-ll (ll) (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords keyword-parameters) @@ -1616,67 +1665,59 @@ (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. +;;; 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 the generic function and of all its +;;; methods. It doesn't take method applicability into account at all +;;; yet. + +;;; (Notice that we ignore &AUX variables as they're not part of the +;;; "public interface" of a function.) + (defmethod generic-function-pretty-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))) - (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)))))) - (values (nreverse required) - (nreverse optional) - rest - (nreverse key) - allow-other-keys))) - + (let ((gf-lambda-list (generic-function-lambda-list generic-function)) + (methods (generic-function-methods generic-function))) + (if (null methods) + gf-lambda-list + (multiple-value-bind (gf.required gf.optional gf.rest gf.keys gf.allowp) + (%split-arglist gf-lambda-list) + ;; Possibly extend the keyword parameters of the gf by + ;; additional key parameters of its methods: + (let ((methods.keys nil) (methods.allowp nil)) + (dolist (m methods) + (multiple-value-bind (m.keyparams m.allow-other-keys) + (function-keyword-parameters m) + (setq methods.keys (union methods.keys m.keyparams :key #'maybe-car)) + (setq methods.allowp (or methods.allowp m.allow-other-keys)))) + (let ((arglist '())) + (when (or gf.allowp methods.allowp) + (push '&allow-other-keys arglist)) + (when (or gf.keys methods.keys) + ;; We make sure that the keys of the gf appear before + ;; those of its methods, since they're probably more + ;; generally appliable. + (setq arglist (nconc (list '&key) gf.keys + (nset-difference methods.keys gf.keys) + arglist))) + (when gf.rest + (setq arglist (nconc (list '&rest gf.rest) arglist))) + (when gf.optional + (setq arglist (nconc (list '&optional) gf.optional arglist))) + (nconc gf.required arglist))))))) + +(defun maybe-car (thing) + (if (listp thing) + (car thing) + thing)) + + +(defun %split-arglist (lambda-list) + ;; This function serves to shrink the number of returned values of + ;; 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 :silent t) + (declare (ignore restp keyp auxp aux morep)) + (declare (ignore more-context more-count)) + (values required optional rest keys allowp)))