From fb201406eb769d73464dab1973da2c53c6197a67 Mon Sep 17 00:00:00 2001
From: Juan Jose Garcia Ripoll <jjgarcia@users.sourceforge.net>
Date: Mon, 23 Apr 2012 23:09:10 +0200
Subject: [PATCH] Wrapping is taken care of fully in INSTALL-METHOD

---
 src/clos/fixup.lsp    |  6 +++---
 src/clos/kernel.lsp   |  8 +++++++-
 src/clos/method.lsp   | 12 +++---------
 src/clos/standard.lsp |  4 ++--
 4 files changed, 15 insertions(+), 15 deletions(-)

diff --git a/src/clos/fixup.lsp b/src/clos/fixup.lsp
index a5b4a4637..1459fd283 100644
--- a/src/clos/fixup.lsp
+++ b/src/clos/fixup.lsp
@@ -254,9 +254,9 @@ their lambda lists ~A and ~A are not congruent."
  '(gf args)
  'nil
  'nil
- (wrapped-method-function
-  #'(ext:lambda-block compute-applicable-methods (gf args)
-     (std-compute-applicable-methods gf args))))
+ #'(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 compute-applicable-methods-using-classes
diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp
index d9681ae46..af9effd86 100644
--- a/src/clos/kernel.lsp
+++ b/src/clos/kernel.lsp
@@ -215,12 +215,13 @@
 ;;; ----------------------------------------------------------------------
 ;;; Methods
 
-(defun install-method (name qualifiers specializers lambda-list doc plist fun
+(defun install-method (name qualifiers specializers lambda-list doc plist fun wrap
 		       &optional method-class &rest options)
   (declare (ignore doc)
 	   (notinline ensure-generic-function))
 ;  (record-definition 'method `(method ,name ,@qualifiers ,specializers))
   (let* ((gf (ensure-generic-function name))
+	 (fun (if wrap (wrapped-method-function fun) fun))
 	 (specializers (mapcar #'(lambda (x)
 				   (cond ((consp x) (intern-eql-specializer (second x)))
 					 ((typep x 'specializer) x)
@@ -235,6 +236,11 @@
     (add-method gf method)
     method))
 
+(defun wrapped-method-function (method-function)
+  #'(lambda (.combined-method-args. *next-methods*)
+      (declare (special .combined-method-args. *next-methods*))
+      (apply method-function .combined-method-args.)))
+
 ;;; ----------------------------------------------------------------------
 ;;;                                                         early versions
 
diff --git a/src/clos/method.lsp b/src/clos/method.lsp
index 1b66e0a7a..57cf514e7 100644
--- a/src/clos/method.lsp
+++ b/src/clos/method.lsp
@@ -48,17 +48,12 @@
 			       `(install-method ',name ',qualifiers
 						,(list 'si::quasiquote specializers)
 						',lambda-list ',doc
-						',plist ,fn-form))))))
+						',plist ,fn-form t))))))
 
 
 ;;; ----------------------------------------------------------------------
 ;;;                                                  method body expansion
 
-(defun wrapped-method-function (method-function)
-  #'(lambda (.combined-method-args. *next-methods*)
-      (declare (special .combined-method-args. *next-methods*))
-      (apply method-function .combined-method-args.)))
-
 (defun expand-defmethod (generic-function-name qualifiers lambda-list
 			 required-parameters specializers body env)
   (declare (ignore qualifiers)
@@ -126,13 +121,12 @@
 			     .next-methods.))
 		      ,@real-body)))))
 	(values
-	 `(wrapped-method-function
-	   #'(ext::lambda-block ,generic-function-name
+	 `#'(ext::lambda-block ,generic-function-name
 	      ,lambda-list
 	      ,@(and class-declarations `((declare ,@class-declarations)))
 	      ,@(if copied-variables
 		    `((let* ,copied-variables ,@real-body))
-		    real-body)))
+		    real-body))
 	 documentation
 	 plist)))))
 
diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp
index a8bb9e2dd..c1bd6e6b0 100644
--- a/src/clos/standard.lsp
+++ b/src/clos/standard.lsp
@@ -698,10 +698,10 @@ because it contains a reference to the undefined class~%  ~A"
 				    writer-args))))
 	(dolist (fname (slot-definition-readers slotd))
 	  (install-method fname nil `(,standard-class) '(self) nil nil
-			  reader reader-class :slot-definition slotd))
+			  reader t reader-class :slot-definition slotd))
 	(dolist (fname (slot-definition-writers slotd))
 	  (install-method fname nil `(,(find-class t) ,standard-class) '(value self)
-			  nil nil writer writer-class :slot-definition slotd))))))
+			  nil nil writer t writer-class :slot-definition slotd))))))
 
 ;;; ======================================================================
 ;;; STANDARD-OBJECT