(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)
- (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))
\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"
"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)))
-||#
\f
-;;; 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)
(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))))))
;; 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
(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
\f
(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)
: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)))
+ (when (arg-info-valid-p (gf-arg-info gf))
(update-dfun gf))
(map-dependents gf (lambda (dependent)
(apply #'update-dependent gf dependent args))))))
(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)))))
+
+(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 "~@<Specializing on the second argument to ~S has ~
+ unportable effects, and also interferes with ~
+ precomputation of print functions for exceptional ~
+ situations.~@:>"
+ :format-arguments (list 'print-object)))
+
(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* ((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))
-
- (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 "~@<Invalid qualifiers for standard method combination ~
- in method ~S:~2I~_~S.~@:>"
- method qualifiers)))
- ((short-method-combination-p mc)
- (let ((mc-name (method-combination-type mc)))
- (when (or (null qualifiers)
- (cdr qualifiers)
- (and (neq (car qualifiers) :around)
- (neq (car qualifiers) mc-name)))
- (warn "~@<Invalid qualifiers for ~S method combination ~
- in method ~S:~2I~_~S.~@:>"
- 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 "~@<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))
+ (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 "~@<Invalid qualifiers for standard method ~
+ combination in method ~S:~2I~_~S.~@:>"
+ 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 "~@<Invalid qualifiers for ~S method combination ~
+ in method ~S:~2I~_~S.~@:>"
+ 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)))
- generic-function)))
+ (when (eq generic-function (method-generic-function 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 #'keyword-spec-name 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)))))))
\f
(defun compute-applicable-methods-function (generic-function arguments)
(values (compute-applicable-methods-using-types
(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))
))
\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)))
-(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
(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)
(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)))
(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))))
(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)))
(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)
(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)))
(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)
(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-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)))
(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))
(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)
(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.)
(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
+ (get-fun1 `(named-lambda (gf-dispatch ,name)
,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)
(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)))
+
+;;; this is the normal function for computing the discriminating
+;;; function of a standard-generic-function
+(let (initial-print-object-cache)
+ (defun standard-compute-discriminating-function (gf)
+ (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))))))
+
+;;; in general we need to support SBCL's encapsulation for generic
+;;; functions: the default implementation of encapsulation changes the
+;;; identity of the function bound to a name, which breaks anything
+;;; class-based, so we implement the encapsulation ourselves in the
+;;; discriminating function.
+(defun sb-impl::encapsulate-generic-function (gf type body)
+ (push (cons type body) (generic-function-encapsulations gf))
+ (reinitialize-instance gf))
+(defun sb-impl::unencapsulate-generic-function (gf type)
+ (setf (generic-function-encapsulations gf)
+ (remove type (generic-function-encapsulations gf)
+ :key #'car :count 1))
+ (reinitialize-instance gf))
+(defun sb-impl::encapsulated-generic-function-p (gf type)
+ (position type (generic-function-encapsulations gf) :key #'car))
+(defun standard-compute-discriminating-function-with-encapsulations (gf encs)
+ (if (null encs)
+ (standard-compute-discriminating-function gf)
+ (let ((inner (standard-compute-discriminating-function-with-encapsulations
+ gf (cdr encs)))
+ (body (cdar encs)))
+ (lambda (&rest args)
+ (let ((sb-int:arg-list args)
+ (sb-int:basic-definition inner))
+ (declare (special sb-int:arg-list sb-int:basic-definition))
+ (eval body))))))
(defmethod compute-discriminating-function ((gf standard-generic-function))
- (with-slots (dfun-state arg-info) gf
- (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)))))
- (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))))))
+ (standard-compute-discriminating-function-with-encapsulations
+ gf (generic-function-encapsulations gf)))
\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)
+ (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)
(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 :silent t)
+ (declare (ignore restp keyp auxp aux morep))
+ (declare (ignore more-context more-count))
+ (values required optional rest keys allowp)))
projects / sbcl.git / blobdiff