MAKE-METHOD-LAMBDA is a generic function. Method documentation is stored in the method itself.

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))

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

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

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