From e0806c1d8c89f9f1bcbc2f147484170d43f0cbe0 Mon Sep 17 00:00:00 2001
From: Alastair Bridgewater <nyef_sbcl@lisphacker.com>
Date: Thu, 31 Mar 2011 20:58:14 -0400
Subject: [PATCH] setf: Record the original lambda-list for complex
 setf-expander functions.

  * Added an extra parameter to ASSIGN-SETF-MACRO for the lambda-list.

  * In ASSIGN-SETF-MACRO, when working with an EXPANDER (as opposed to
an INVERSE), set the %FUN-LAMBDA-LIST of the EXPANDER to the value
passed as the new parameter.

  * In all call sites for ASSIGN-SETF-MACRO (two uses in DEFSETF, one in
DEFINE-SETF-EXPANDER), pass the new lambda-list parameter appropriately.
---
 src/code/early-setf.lisp |    9 ++++++++-
 1 file changed, 8 insertions(+), 1 deletion(-)

diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp
index 91808a0..6533da9 100644
--- a/src/code/early-setf.lisp
+++ b/src/code/early-setf.lisp
@@ -338,7 +338,8 @@
 
 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
   ;;; Assign SETF macro information for NAME, making all appropriate checks.
-  (defun assign-setf-macro (name expander inverse doc)
+  (defun assign-setf-macro (name expander expander-lambda-list inverse doc)
+    #+sb-xc-host (declare (ignore expander-lambda-list))
     (with-single-package-locked-error
         (:symbol name "defining a setf-expander for ~A"))
     (cond ((gethash name sb!c:*setf-assumed-fboundp*)
@@ -354,6 +355,9 @@
            (style-warn "defining setf macro for ~S when ~S is fbound"
                        name `(setf ,name))))
     (remhash name sb!c:*setf-assumed-fboundp*)
+    #-sb-xc-host
+    (when expander
+      (setf (%fun-lambda-list expander) expander-lambda-list))
     ;; FIXME: It's probably possible to join these checks into one form which
     ;; is appropriate both on the cross-compilation host and on the target.
     (when (or inverse (info :setf :inverse name))
@@ -372,6 +376,7 @@
          `(eval-when (:load-toplevel :compile-toplevel :execute)
             (assign-setf-macro ',access-fn
                                nil
+                               nil
                                ',(car rest)
                                 ,(when (and (car rest) (stringp (cadr rest)))
                                    `',(cadr rest)))))
@@ -393,6 +398,7 @@
                      (%defsetf ,access-form ,(length store-variables)
                                (lambda (,whole)
                                  ,body)))
+                   ',lambda-list
                    nil
                    ',doc))))))
         (t
@@ -443,6 +449,7 @@
                             (lambda (,whole ,environment)
                               ,@local-decs
                               ,body)
+                            ',lambda-list
                             nil
                             ',doc)))))
 
-- 
1.7.10.4