X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=d2e5d9c7429f5a8bd3e1c0705e0846428ce7b34b;hb=45bc305be4e269d2e1a477c8e0ae9a64df1ccd1c;hp=f20381044be1047403f2e8d6c0e44880ead08076;hpb=2c4f8db463028034cf6d10c45f35e3b9ecb7378c;p=sbcl.git diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index f203810..d2e5d9c 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 @@ -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 @@ -434,41 +433,58 @@ (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)))) + (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) + (values-for-add-method generic-function method) + (when method-gf + (error "~@" + method method-gf)) (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 +498,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)) @@ -590,7 +606,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)) @@ -640,20 +656,6 @@ (defmethod specializer-class ((specializer eql-specializer)) (class-of (slot-value specializer 'object))) -;;; KLUDGE: this is needed to allow for user-defined specializers in -;;; RAISE-METATYPE; however, the list of methods is maintained by -;;; hand, which is error-prone. We can't just add a method to -;;; SPECIALIZER-CLASS, or at least not with confidence, as that -;;; function is used elsewhere in PCL. `STANDARD' here is used in the -;;; sense of `comes with PCL' rather than `blessed by the -;;; authorities'. -- CSR, 2007-05-10 -(defmethod standard-specializer-p ((specializer class)) t) -(defmethod standard-specializer-p ((specializer eql-specializer)) t) -(defmethod standard-specializer-p ((specializer class-eq-specializer)) t) -(defmethod standard-specializer-p ((specializer class-prototype-specializer)) - t) -(defmethod standard-specializer-p ((specializer specializer)) nil) - (defun specializer-class-or-nil (specializer) (and (standard-specializer-p specializer) (specializer-class specializer))) @@ -745,22 +747,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))) @@ -831,8 +834,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))) @@ -1374,7 +1377,7 @@ (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 nargs applyp 'emf)))) @@ -1564,13 +1567,14 @@ (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) +(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)) - (values keywords allow-other-keys-p))) + (declare (ignore nreq nopt keysp restp keywords)) + (values keyword-parameters allow-other-keys-p))) (defun method-ll->generic-function-ll (ll) (multiple-value-bind @@ -1582,67 +1586,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) + (declare (ignore restp keyp auxp aux morep)) + (declare (ignore more-context more-count)) + (values required optional rest keys allowp)))