(check-slot-name method slot-name)))
(defmethod shared-initialize :after ((method standard-method) slot-names
- &rest initargs &key)
- (declare (ignore slot-names))
+ &rest initargs &key ((method-cell method-cell)))
+ (declare (ignore slot-names method-cell))
(initialize-method-function initargs method))
-
\f
(defvar *the-class-generic-function*
(find-class 'generic-function))
(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)
+(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
:generic-function-class (class-of existing-gf))
(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))
+ (proto (method-prototype-for-gf generic-function-name)))
+ (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)
;; 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))
\f
;;; 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
))
\f
(defmethod same-specializer-p ((specl1 specializer) (specl2 specializer))
- nil)
+ (eql specl1 specl2))
(defmethod same-specializer-p ((specl1 class) (specl2 class))
(eq specl1 specl2))
(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)))
+
(defun error-need-at-least-n-args (function n)
(error 'simple-program-error
:format-control "~@<The function ~2I~_~S ~I~_requires ~
(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)))
+ (when (and %wrappers (not (probe-cache cache %wrappers)))
(let ((value (cond ((eq valuep t)
(sdfun-for-caching generic-function
classes))
((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))))))
\f
(defmethod (setf class-name) (new-value class)
projects / sbcl.git / blobdiff