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
(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
(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 "~@<The method ~S is already part of the generic ~
- function ~S; it can't be added to another generic ~
- function until it is removed from the first one.~@:>"
- 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 "~@<The method ~S is already part of the generic ~
+ function ~S; it can't be added to another generic ~
+ function until it is removed from the first one.~@:>"
+ 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
(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))
(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))
(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)))
(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)))
(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)))
(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))))
(reinitialize-instance generic-function :name new-value)
new-value)
\f
-(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
(eq s '&allow-other-keys)))
ll)))
\f
-;;; 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)))
projects / sbcl.git / blobdiff