X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-setf.lisp;h=3cddab43f5904ec4a489a441072a99400f9cfff7;hb=829ced3e78a23ba153ba4db64e6ea6984c2313b6;hp=e3884e3a0f9878f1a28a7797e3e160bff893a30d;hpb=3c3006c51658323c44c3cec859838bde3ea6b565;p=sbcl.git

diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp
index e3884e3..3cddab4 100644
--- a/src/code/early-setf.lisp
+++ b/src/code/early-setf.lisp
@@ -70,25 +70,6 @@
           (t
            (expand-or-get-setf-inverse form environment)))))
 
-;;; GET-SETF-METHOD existed in pre-ANSI Common Lisp, and various code inherited
-;;; from CMU CL uses it repeatedly, so rather than rewrite a lot of code to not
-;;; use it, we just define it in terms of ANSI's GET-SETF-EXPANSION (or
-;;; actually, the cross-compiler version of that, i.e.
-;;; SB!XC:GET-SETF-EXPANSION).
-(declaim (ftype (function (t &optional (or null sb!c::lexenv))) get-setf-method))
-(defun get-setf-method (form &optional environment)
-  #!+sb-doc
-  "This is a specialized-for-one-value version of GET-SETF-EXPANSION (and
-a relic from pre-ANSI Common Lisp). Portable ANSI code should use
-GET-SETF-EXPANSION directly."
-  (multiple-value-bind (temps value-forms store-vars store-form access-form)
-      (sb!xc:get-setf-expansion form environment)
-    (when (cdr store-vars)
-      (error "GET-SETF-METHOD used for a form with multiple store ~
-              variables:~%  ~S"
-             form))
-    (values temps value-forms store-vars store-form access-form)))
-
 ;;; If a macro, expand one level and try again. If not, go for the
 ;;; SETF function.
 (declaim (ftype (function (t (or null sb!c::lexenv)))
@@ -112,7 +93,7 @@ GET-SETF-EXPANSION directly."
       (cond ((sb!xc:constantp x environment)
              (push x args))
             (t
-             (let ((temp (gensym "TMP")))
+             (let ((temp (gensymify x)))
                (push temp args)
                (push temp vars)
                (push x vals)))))
@@ -357,7 +338,8 @@ GET-SETF-EXPANSION directly."
 
 (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*)
@@ -373,6 +355,9 @@ GET-SETF-EXPANSION directly."
            (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))
@@ -391,6 +376,7 @@ GET-SETF-EXPANSION directly."
          `(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)))))
@@ -412,6 +398,7 @@ GET-SETF-EXPANSION directly."
                      (%defsetf ,access-form ,(length store-variables)
                                (lambda (,whole)
                                  ,body)))
+                   ',lambda-list
                    nil
                    ',doc))))))
         (t
@@ -462,6 +449,7 @@ GET-SETF-EXPANSION directly."
                             (lambda (,whole ,environment)
                               ,@local-decs
                               ,body)
+                            ',lambda-list
                             nil
                             ',doc)))))
 
@@ -479,6 +467,7 @@ GET-SETF-EXPANSION directly."
               `(,newval)
               `(let ((,(car stores) (%putf ,get ,ptemp ,newval))
                      ,@(cdr stores))
+                 ,def-temp ;; prevent unused style-warning
                  ,set
                  ,newval)
               `(getf ,get ,ptemp ,@(if default `(,def-temp)))))))
@@ -486,24 +475,26 @@ GET-SETF-EXPANSION directly."
 (sb!xc:define-setf-expander get (symbol prop &optional default)
   (let ((symbol-temp (gensym))
         (prop-temp (gensym))
-        (def-temp (gensym))
+        (def-temp (if default (gensym)))
         (newval (gensym)))
     (values `(,symbol-temp ,prop-temp ,@(if default `(,def-temp)))
             `(,symbol ,prop ,@(if default `(,default)))
             (list newval)
-            `(%put ,symbol-temp ,prop-temp ,newval)
+            `(progn ,def-temp ;; prevent unused style-warning
+                    (%put ,symbol-temp ,prop-temp ,newval))
             `(get ,symbol-temp ,prop-temp ,@(if default `(,def-temp))))))
 
 (sb!xc:define-setf-expander gethash (key hashtable &optional default)
   (let ((key-temp (gensym))
         (hashtable-temp (gensym))
-        (default-temp (gensym))
+        (default-temp (if default (gensym)))
         (new-value-temp (gensym)))
     (values
      `(,key-temp ,hashtable-temp ,@(if default `(,default-temp)))
      `(,key ,hashtable ,@(if default `(,default)))
      `(,new-value-temp)
-     `(%puthash ,key-temp ,hashtable-temp ,new-value-temp)
+     `(progn ,default-temp ;; prevent unused style-warning
+             (%puthash ,key-temp ,hashtable-temp ,new-value-temp))
      `(gethash ,key-temp ,hashtable-temp ,@(if default `(,default-temp))))))
 
 (sb!xc:define-setf-expander logbitp (index int &environment env)