(in-package "SB-PCL")
\f
-
;;; 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)))
-
+\f
;;; initialization
;;;
;;; Error checking is done in before methods. Because of the simplicity of
;;;
;;; Methods are not reinitializable.
-(defmethod reinitialize-instance ((method standard-method) &rest initargs)
- (declare (ignore initargs))
- (error "An attempt was made to reinitialize the method ~S.~%~
- Method objects cannot be reinitialized."
- method))
-
-(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 metaobject-initialization-violation
+ (reference-condition simple-error)
+ ())
+
+(macrolet ((def (name args control)
+ `(defmethod ,name ,args
+ (declare (ignore initargs))
+ (error 'metaobject-initialization-violation
+ :format-control ,(format nil "~@<~A~@:>" control)
+ :format-arguments (list ',name)
+ :references (list '(:amop :initialization method))))))
+ (def reinitialize-instance ((method method) &rest initargs)
+ "Method objects cannot be redefined by ~S.")
+ (def change-class ((method method) new &rest initargs)
+ "Method objects cannot be redefined by ~S.")
+ ;; NEW being a subclass of method is dealt with in the general
+ ;; method of CHANGE-CLASS
+ (def update-instance-for-redefined-class ((method method) added discarded
+ plist &rest initargs)
+ "No behaviour specified for ~S on method objects.")
+ (def update-instance-for-different-class (old (new method) &rest initargs)
+ "No behaviour specified for ~S on method objects.")
+ (def update-instance-for-different-class ((old method) new &rest initargs)
+ "No behaviour specified for ~S on method objects."))
+
+(define-condition invalid-method-initarg (simple-program-error)
+ ((method :initarg :method :reader invalid-method-initarg-method))
+ (:report
+ (lambda (c s)
+ (format s "~@<In initialization of ~S:~2I~_~?~@:>"
+ (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 "~@<Defining a method using ~
+ ~V[~;~1{~S~}~;~1{~S and ~S~}~:;~{~#[~;and ~]~S~^, ~}~] ~
+ as ~2:*~V[~;a specializer~:;specializers~].~@:>"
+ (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)
+ &rest initargs &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))
+ (initialize-method-function initargs method))
+
\f
(defvar *the-class-generic-function*
(find-class 'generic-function))
(initarg-error :method-combination
method-combination
"a method combination object")))
- ((slot-boundp generic-function 'method-combination))
+ ((slot-boundp generic-function '%method-combination))
(t
(initarg-error :method-combination
"not supplied"
; :argument-precedence-order
; 'argument-precedence-order)
; (add-initarg declarations :declarations 'declarations)
-; (add-initarg documentation :documentation 'documentation)
+; (add-initarg documentation :documentation '%documentation)
; (add-initarg method-class :method-class 'method-class)
-; (add-initarg method-combination :method-combination 'method-combination)
+; (add-initarg method-combination :method-combination '%method-combination)
(apply #'call-next-method generic-function initargs)))
||#
\f
:argument-precedence-order argument-precedence-order))
(lambda-list-p (set-arg-info gf :lambda-list lambda-list))
(t (set-arg-info gf)))
- (when (and (arg-info-valid-p (gf-arg-info gf))
- (not (null args))
- (or lambda-list-p (cddr args)))
- (update-dfun gf)))))
+ (when (arg-info-valid-p (gf-arg-info gf))
+ (update-dfun gf))
+ (map-dependents gf (lambda (dependent)
+ (apply #'update-dependent gf dependent args))))))
(declaim (special *lazy-dfun-compute-p*))
(loop (when (null methods) (return gf))
(real-add-method gf (pop methods) methods)))
+(define-condition new-value-specialization (reference-condition error)
+ ((%method :initarg :method :reader new-value-specialization-method))
+ (:report
+ (lambda (c s)
+ (format s "~@<Cannot add method ~S to ~S, as it specializes the ~
+ new-value argument.~@:>"
+ (new-value-specialization-method c)
+ #'(setf slot-value-using-class))))
+ (:default-initargs :references
+ (list '(:sbcl :node "Metaobject Protocol")
+ '(:amop :generic-function (setf slot-value-using-class)))))
+
(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 ~
(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)
in method ~S:~2I~_~S.~@:>"
method qualifiers)))
((short-method-combination-p mc)
- (let ((mc-name (method-combination-type mc)))
+ (let ((mc-name (method-combination-type-name mc)))
(when (or (null qualifiers)
(cdr qualifiers)
(and (neq (car qualifiers) :around)
: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)))
(defun real-remove-method (generic-function method)
- (when (eq generic-function (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))
(update-ctors 'remove-method
:generic-function generic-function
:method method)
- (update-dfun generic-function)))
+ (update-dfun generic-function)
+ (map-dependents generic-function
+ (lambda (dep)
+ (update-dependent generic-function
+ dep 'remove-method method)))))
generic-function)
\f
(defun compute-applicable-methods-function (generic-function arguments)
(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 error-need-at-least-n-args (function n)
(error 'simple-program-error
:format-control "~@<The function ~2I~_~S ~I~_requires ~
(defun value-for-caching (gf classes)
(let ((methods (compute-applicable-methods-using-types
gf (mapcar #'class-eq-type classes))))
- (method-function-get (or (method-fast-function (car methods))
- (method-function (car methods)))
- :constant-value)))
+ (method-plist-value (car methods) :constant-value)))
(defun default-secondary-dispatch-function (generic-function)
(lambda (&rest args)
(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)
(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)
(eq (pop specls) *the-class-t*))
(every #'classp specls))
(cond ((and (eq (class-name (car specls)) 'std-class)
- (eq (class-name (cadr specls)) 'std-object)
+ (eq (class-name (cadr specls)) 'standard-object)
(eq (class-name (caddr specls))
'standard-effective-slot-definition))
(set-standard-svuc-method type method))
(set-structure-svuc-method type method)))))))
(defun mec-all-classes-internal (spec precompute-p)
- (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-std-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)))
(default '(default)))
(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
+ (eq default (probe-cache cache %wrappers default)))
(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))
cache)))
(defmacro class-test (arg class)
- (cond ((eq class *the-class-t*)
- t)
- ((eq class *the-class-slot-object*)
- `(not (typep (classoid-of ,arg)
- 'built-in-classoid)))
- ((eq class *the-class-std-object*)
- `(or (std-instance-p ,arg) (fsc-instance-p ,arg)))
- ((eq class *the-class-standard-object*)
- `(std-instance-p ,arg))
- ((eq class *the-class-funcallable-standard-object*)
- `(fsc-instance-p ,arg))
- (t
- `(typep ,arg ',(class-name class)))))
+ (cond
+ ((eq class *the-class-t*) t)
+ ((eq class *the-class-slot-object*)
+ `(not (typep (classoid-of ,arg) 'built-in-classoid)))
+ ((eq class *the-class-standard-object*)
+ `(or (std-instance-p ,arg) (fsc-instance-p ,arg)))
+ ((eq class *the-class-funcallable-standard-object*)
+ `(fsc-instance-p ,arg))
+ (t
+ `(typep ,arg ',(class-name class)))))
(defmacro class-eq-test (arg class)
`(eq (class-of ,arg) ',class))
(defun generate-discrimination-net (generic-function methods types sorted-p)
(let* ((arg-info (gf-arg-info generic-function))
- (c-a-m-emf-std-p (gf-info-c-a-m-emf-std-p arg-info))
+ (c-a-m-emf-std-p (gf-info-c-a-m-emf-std-p arg-info))
(precedence (arg-info-precedence arg-info)))
(generate-discrimination-net-internal
generic-function methods types
(lambda (methods known-types)
(if (or sorted-p
- (and c-a-m-emf-std-p
- (block one-order-p
- (let ((sorted-methods nil))
- (map-all-orders
- (copy-list methods) precedence
- (lambda (methods)
- (when sorted-methods (return-from one-order-p nil))
- (setq sorted-methods methods)))
- (setq methods sorted-methods))
- t)))
+ (and c-a-m-emf-std-p
+ (block one-order-p
+ (let ((sorted-methods nil))
+ (map-all-orders
+ (copy-list methods) precedence
+ (lambda (methods)
+ (when sorted-methods (return-from one-order-p nil))
+ (setq sorted-methods methods)))
+ (setq methods sorted-methods))
+ t)))
`(methods ,methods ,known-types)
`(unordered-methods ,methods ,known-types)))
(lambda (position type true-value false-value)
(make-dfun-lambda-list metatypes applyp)
(make-fast-method-call-lambda-list metatypes applyp))))
(multiple-value-bind (cfunction constants)
- (get-fun1 `(,(if function-p
- 'instance-lambda
- 'lambda)
+ (get-fun1 `(lambda
,arglist
,@(unless function-p
`((declare (ignore .pv-cell.
(declare (ignore class))
(function-funcall (slot-definition-boundp-function 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 (let ((name (generic-function-name gf)))
- (when (eq name 'compute-applicable-methods)
- (update-all-c-a-m-gf-info gf))
- (cond ((eq name 'slot-value-using-class)
- (update-slot-value-gf-info gf 'reader)
- #'slot-value-using-class-dfun)
- ((equal name '(setf slot-value-using-class))
- (update-slot-value-gf-info gf 'writer)
- #'setf-slot-value-using-class-dfun)
- ((eq name '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)))))
+ (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)
- #|| (name (generic-function-name gf)) ||#
(arg-info (gf-arg-info gf)))
- (cond #||
- ((eq name 'slot-value-using-class)
- (update-slot-value-gf-info gf 'reader))
- ((equal name '(setf slot-value-using-class))
- (update-slot-value-gf-info gf 'writer))
- ((eq name 'slot-boundp-using-class)
- (update-slot-value-gf-info gf 'boundp))
- ||#
- ((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))))))
+ (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))))))
\f
-(defmethod (setf class-name) :before (new-value (class class))
- (let ((classoid (find-classoid (class-name class))))
- (setf (classoid-name classoid) new-value)))
+(defmethod (setf class-name) (new-value class)
+ (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)
+
+(defmethod (setf generic-function-name) (new-value generic-function)
+ (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)
projects / sbcl.git / blobdiff