X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=954619a5c5cfe69cf58f63b2a945759a6871ad9e;hb=990728854b8ba017888811d1b0453b15dfa8a581;hp=f488ae3cdb94b9379e41e0c3faef7ed1bf98da68;hpb=81c6f85203df993c7e29ac5f75d50c705dbbfd8d;p=sbcl.git diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index f488ae3..954619a 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -152,10 +152,9 @@ (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)) - (defvar *the-class-generic-function* (find-class 'generic-function)) @@ -209,59 +208,35 @@ (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))) -||# -;;; 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)) + (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))) + (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) @@ -310,11 +285,14 @@ ;; 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)) ;;; 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 @@ -630,7 +608,7 @@ )) (defmethod same-specializer-p ((specl1 specializer) (specl2 specializer)) - nil) + (eql specl1 specl2)) (defmethod same-specializer-p ((specl1 class) (specl2 class)) (eq specl1 specl2)) @@ -649,6 +627,24 @@ (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 "~@