diff --git a/src/clos/fixup.lsp b/src/clos/fixup.lsp index 536557ed7..c5d774132 100644 --- a/src/clos/fixup.lsp +++ b/src/clos/fixup.lsp @@ -117,8 +117,7 @@ (defun method-p (method) (typep method 'METHOD)) -(defun make-method (method-class qualifiers specializers arglist - function plist options) +(defun make-method (method-class qualifiers specializers arglist function options) (apply #'make-instance method-class :generic-function nil @@ -126,7 +125,6 @@ :lambda-list arglist :specializers specializers :function function - :plist plist :allow-other-keys t options)) @@ -247,16 +245,11 @@ their lambda lists ~A and ~A are not congruent." (:method ((gf standard-generic-function) args) (std-compute-applicable-methods gf args))) -(install-method - 'aux-compute-applicable-methods - 'nil - '(standard-generic-function t) - '(gf args) - 'nil - #'(ext:lambda-block compute-applicable-methods (gf args) - (std-compute-applicable-methods gf args)) - t) -(setf (fdefinition 'compute-applicable-methods) #'aux-compute-applicable-methods) +(defmethod aux-compute-applicable-methods ((gf standard-generic-function) args) + (std-compute-applicable-methods gf args)) +(let ((aux #'aux-compute-applicable-methods)) + (setf (generic-function-name aux) 'compute-applicable-methods + (fdefinition 'compute-applicable-methods) aux)) (defmethod compute-applicable-methods-using-classes ((gf standard-generic-function) classes) @@ -348,3 +341,6 @@ their lambda lists ~A and ~A are not congruent." (add-dependent #'shared-initialize x) (add-dependent #'initialize-instance x) (add-dependent #'allocate-instance x)) + +(function-to-method 'make-method-lambda + '((gf standard-generic-function) (method standard-method) lambda-form environment)) diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index d5071d6c2..4f97ac0a3 100644 --- a/src/clos/kernel.lsp +++ b/src/clos/kernel.lsp @@ -215,8 +215,7 @@ ;;; ---------------------------------------------------------------------- ;;; Methods -(defun install-method (name qualifiers specializers lambda-list doc fun wrap - &optional method-class &rest options) +(defun install-method (name qualifiers specializers lambda-list fun wrap &rest options) (declare (ignore doc) (notinline ensure-generic-function)) ; (record-definition 'method `(method ,name ,@qualifiers ,specializers)) @@ -231,10 +230,9 @@ (print specializers) (error "In method definition for ~A, found an invalid specializer ~A" name specializers)))) specializers)) - (method (make-method (or method-class - (generic-function-method-class gf)) + (method (make-method (generic-function-method-class gf) qualifiers specializers lambda-list - fun nil options))) + fun options))) (add-method gf method) method)) @@ -347,6 +345,9 @@ (defun sort-applicable-methods (gf applicable-list args) (declare (optimize (safety 0) (speed 3))) + (when (null applicable-list) + (print `(not-applicable ,(generic-function-name gf) + ,(mapcar #'type-of args)))) (let ((f (generic-function-a-p-o-function gf)) (args-specializers (mapcar #'class-of args))) ;; reorder args to match the precedence order diff --git a/src/clos/method.lsp b/src/clos/method.lsp index b31d5c40d..997a53b18 100644 --- a/src/clos/method.lsp +++ b/src/clos/method.lsp @@ -61,8 +61,8 @@ (type-of generic-function)))) (multiple-value-bind (fn-form options) (make-method-lambda generic-function method lambda-form env) - (when options - (setf options (list* nil (mapcar #'si::maybe-quote options)))) + (when documentation + (setf options (list* 'documentation documentation options))) (multiple-value-bind (wrapped-lambda wrapped-p) (simplify-lambda name fn-form) (unless wrapped-p @@ -70,10 +70,10 @@ (ext:register-with-pde whole `(install-method ',name ',qualifiers ,(list 'si::quasiquote specializers) - ',lambda-list ',documentation + ',lambda-list ,(maybe-remove-block wrapped-lambda) ,wrapped-p - ,@options))))))))) + ,@(mapcar #'si::maybe-quote options)))))))))) (defun maybe-remove-block (method-lambda) (when (eq (first method-lambda) 'lambda) @@ -338,8 +338,7 @@ have disappeared." collect k))) method)) -(defun make-method (method-class qualifiers specializers lambda-list - fun plist options) +(defun make-method (method-class qualifiers specializers lambda-list fun options) (declare (ignore options)) (let* ((instance-size (+ #.(length +standard-method-slots+) (if (eq method-class 'standard-method) @@ -349,8 +348,7 @@ have disappeared." (method-lambda-list method) lambda-list (method-function method) fun (method-specializers method) specializers - (method-qualifiers method) qualifiers - (method-plist method) plist) + (method-qualifiers method) qualifiers) (add-method-keywords method))) ;;; early version used during bootstrap diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp index 1196d0a3b..47fd06bd1 100644 --- a/src/clos/standard.lsp +++ b/src/clos/standard.lsp @@ -697,11 +697,13 @@ because it contains a reference to the undefined class~% ~A" (apply #'writer-method-class standard-class slotd writer-args)))) (dolist (fname (slot-definition-readers slotd)) - (install-method fname nil `(,standard-class) '(self) nil - reader t reader-class :slot-definition slotd)) + (add-method (ensure-generic-function fname) + (make-method reader-class nil `(,standard-class) '(self) + reader (list :slot-definition slotd)))) (dolist (fname (slot-definition-writers slotd)) - (install-method fname nil `(,(find-class t) ,standard-class) '(value self) - nil writer t writer-class :slot-definition slotd)))))) + (add-method (ensure-generic-function fname) + (make-method writer-class nil `(,(find-class t) ,standard-class) '(value self) + writer (list :slot-definition slotd)))))))) ;;; ====================================================================== ;;; STANDARD-OBJECT