1.1.13: will be tagged as "sbcl-1.1.13"

[sbcl.git] / src / code / early-setf.lisp

diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp
index b09d1f0..3cddab4 100644 (file)
--- a/src/code/early-setf.lisp
+++ b/src/code/early-setf.lisp
@@ -37,83 +37,73 @@
    for the new values, the setting function, and the accessing function."
   (let (temp)
     (cond ((symbolp form)
    for the new values, the setting function, and the accessing function."
   (let (temp)
     (cond ((symbolp form)

-          (multiple-value-bind (expansion expanded)
-              (sb!xc:macroexpand-1 form environment)
-            (if expanded
-                (sb!xc:get-setf-expansion expansion environment)
-                (let ((new-var (gensym)))
-                  (values nil nil (list new-var)
-                          `(setq ,form ,new-var) form)))))
-         ;; Local functions inhibit global SETF methods.
-         ((and environment
-               (let ((name (car form)))
-                 (dolist (x (sb!c::lexenv-funs environment))
-                   (when (and (eq (car x) name)
-                              (not (sb!c::defined-fun-p (cdr x))))
-                     (return t)))))
-          (expand-or-get-setf-inverse form environment))
-         ((setq temp (info :setf :inverse (car form)))
-          (get-setf-method-inverse form `(,temp) nil))
-         ((setq temp (info :setf :expander (car form)))
-          ;; KLUDGE: It may seem as though this should go through
-          ;; *MACROEXPAND-HOOK*, but the ANSI spec seems fairly explicit
-          ;; that *MACROEXPAND-HOOK* is a hook for MACROEXPAND-1, not
-          ;; for macroexpansion in general. -- WHN 19991128
-          (funcall temp
-                   form
-                   ;; As near as I can tell from the ANSI spec,
-                   ;; macroexpanders have a right to expect an actual
-                   ;; lexical environment, not just a NIL which is to
-                   ;; be interpreted as a null lexical environment.
-                   ;; -- WHN 19991128
-                   (coerce-to-lexenv environment)))
-         (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)))
+           (multiple-value-bind (expansion expanded)
+               (%macroexpand-1 form environment)
+             (if expanded
+                 (sb!xc:get-setf-expansion expansion environment)
+                 (let ((new-var (sb!xc:gensym "NEW")))
+                   (values nil nil (list new-var)
+                           `(setq ,form ,new-var) form)))))
+          ;; Local functions inhibit global SETF methods.
+          ((and environment
+                (let ((name (car form)))
+                  (dolist (x (sb!c::lexenv-funs environment))
+                    (when (and (eq (car x) name)
+                               (not (sb!c::defined-fun-p (cdr x))))
+                      (return t)))))
+           (expand-or-get-setf-inverse form environment))
+          ((setq temp (info :setf :inverse (car form)))
+           (get-setf-method-inverse form `(,temp) nil environment))
+          ((setq temp (info :setf :expander (car form)))
+           ;; KLUDGE: It may seem as though this should go through
+           ;; *MACROEXPAND-HOOK*, but the ANSI spec seems fairly explicit
+           ;; that *MACROEXPAND-HOOK* is a hook for MACROEXPAND-1, not
+           ;; for macroexpansion in general. -- WHN 19991128
+           (funcall temp
+                    form
+                    ;; As near as I can tell from the ANSI spec,
+                    ;; macroexpanders have a right to expect an actual
+                    ;; lexical environment, not just a NIL which is to
+                    ;; be interpreted as a null lexical environment.
+                    ;; -- WHN 19991128
+                    (coerce-to-lexenv environment)))
+          (t
+           (expand-or-get-setf-inverse form environment)))))

 
 ;;; If a macro, expand one level and try again. If not, go for the
 ;;; SETF function.
 
 ;;; If a macro, expand one level and try again. If not, go for the
 ;;; SETF function.

-(declaim (ftype (function (t sb!c::lexenv)) expand-or-get-setf-inverse))
+(declaim (ftype (function (t (or null sb!c::lexenv)))
+                expand-or-get-setf-inverse))

 (defun expand-or-get-setf-inverse (form environment)
   (multiple-value-bind (expansion expanded)
 (defun expand-or-get-setf-inverse (form environment)
   (multiple-value-bind (expansion expanded)

-      (sb!xc:macroexpand-1 form environment)
+      (%macroexpand-1 form environment)

     (if expanded
     (if expanded

-       (sb!xc:get-setf-expansion expansion environment)
-       (get-setf-method-inverse form
-                                `(funcall #'(setf ,(car form)))
-                                t))))
+        (sb!xc:get-setf-expansion expansion environment)
+        (get-setf-method-inverse form
+                                 `(funcall #'(setf ,(car form)))
+                                 t
+                                 environment))))

 
 

-(defun get-setf-method-inverse (form inverse setf-fun)
-  (let ((new-var (gensym))
-       (vars nil)
-       (vals nil))
-    (dolist (x (cdr form))
-      (push (gensym) vars)
-      (push x vals))
-    (setq vals (nreverse vals))
-    (values vars vals (list new-var)
-           (if setf-fun
-               `(,@inverse ,new-var ,@vars)
-               `(,@inverse ,@vars ,new-var))
-           `(,(car form) ,@vars))))
+(defun get-setf-method-inverse (form inverse setf-fun environment)
+  (let ((new-var (sb!xc:gensym "NEW"))
+        (vars nil)
+        (vals nil)
+        (args nil))
+    (dolist (x (reverse (cdr form)))
+      (cond ((sb!xc:constantp x environment)
+             (push x args))
+            (t
+             (let ((temp (gensymify x)))
+               (push temp args)
+               (push temp vars)
+               (push x vals)))))
+    (values vars
+            vals
+            (list new-var)
+            (if setf-fun
+                `(,@inverse ,new-var ,@args)
+                `(,@inverse ,@args ,new-var))
+            `(,(car form) ,@args))))

 \f
 ;;;; SETF itself
 
 \f
 ;;;; SETF itself
 

@@ -133,26 +123,26 @@ GET-SETF-EXPANSION directly."
     (cond
      ((= nargs 2)
       (let ((place (first args))
     (cond
      ((= nargs 2)
       (let ((place (first args))

-           (value-form (second args)))
-       (if (atom place)
-         `(setq ,place ,value-form)
-         (multiple-value-bind (dummies vals newval setter getter)
-             (sb!xc:get-setf-expansion place env)
-           (declare (ignore getter))
-           (let ((inverse (info :setf :inverse (car place))))
-             (if (and inverse (eq inverse (car setter)))
-               `(,inverse ,@(cdr place) ,value-form)
-               `(let* (,@(mapcar #'list dummies vals))
-                  (multiple-value-bind ,newval ,value-form
-                    ,setter))))))))
+            (value-form (second args)))
+        (if (atom place)
+          `(setq ,place ,value-form)
+          (multiple-value-bind (dummies vals newval setter getter)
+              (sb!xc:get-setf-expansion place env)
+            (declare (ignore getter))
+            (let ((inverse (info :setf :inverse (car place))))
+              (if (and inverse (eq inverse (car setter)))
+                `(,inverse ,@(cdr place) ,value-form)
+                `(let* (,@(mapcar #'list dummies vals))
+                   (multiple-value-bind ,newval ,value-form
+                     ,setter))))))))

      ((oddp nargs)
       (error "odd number of args to SETF"))
      (t
       (do ((a args (cddr a))
      ((oddp nargs)
       (error "odd number of args to SETF"))
      (t
       (do ((a args (cddr a))

-          (reversed-setfs nil))
-         ((null a)
-          `(progn ,@(nreverse reversed-setfs)))
-       (push (list 'setf (car a) (cadr a)) reversed-setfs))))))
+           (reversed-setfs nil))
+          ((null a)
+           `(progn ,@(nreverse reversed-setfs)))
+        (push (list 'setf (car a) (cadr a)) reversed-setfs))))))

 \f
 ;;;; various SETF-related macros
 
 \f
 ;;;; various SETF-related macros
 

@@ -164,47 +154,68 @@ GET-SETF-EXPANSION directly."
    returning the value of the leftmost."
   (when (< (length args) 2)
     (error "~S called with too few arguments: ~S" 'shiftf form))
    returning the value of the leftmost."
   (when (< (length args) 2)
     (error "~S called with too few arguments: ~S" 'shiftf form))

-  (let ((resultvar (gensym)))
-    (do ((arglist args (cdr arglist))
-        (bindlist nil)
-        (storelist nil)
-        (lastvar resultvar))
-       ((atom (cdr arglist))
-        (push `(,lastvar ,(first arglist)) bindlist)
-        `(let* ,(nreverse bindlist) ,@(nreverse storelist) ,resultvar))
-      (multiple-value-bind (sm1 sm2 sm3 sm4 sm5)
-         (get-setf-method (first arglist) env)
-       (mapc (lambda (var val)
-               (push `(,var ,val) bindlist))
-             sm1
-             sm2)
-       (push `(,lastvar ,sm5) bindlist)
-       (push sm4 storelist)
-       (setq lastvar (first sm3))))))
+  (let (let*-bindings mv-bindings setters getters)
+    (dolist (arg (butlast args))
+      (multiple-value-bind (temps subforms store-vars setter getter)
+          (sb!xc:get-setf-expansion arg env)
+        (mapc (lambda (tmp form)
+                (push `(,tmp ,form) let*-bindings))
+              temps
+              subforms)
+        (push store-vars mv-bindings)
+        (push setter setters)
+        (push getter getters)))
+    ;; Handle the last arg specially here. The getter is just the last
+    ;; arg itself.
+    (push (car (last args)) getters)
+
+    ;; Reverse the collected lists so last bit looks nicer.
+    (setf let*-bindings (nreverse let*-bindings)
+          mv-bindings (nreverse mv-bindings)
+          setters (nreverse setters)
+          getters (nreverse getters))
+
+    (labels ((thunk (mv-bindings getters)
+               (if mv-bindings
+                   `((multiple-value-bind
+                           ,(car mv-bindings)
+                         ,(car getters)
+                       ,@(thunk (cdr mv-bindings) (cdr getters))))
+                   `(,@setters))))
+      `(let ,let*-bindings
+        (multiple-value-bind ,(car mv-bindings)
+            ,(car getters)
+          ,@(thunk mv-bindings (cdr getters))
+          (values ,@(car mv-bindings)))))))

 
 (defmacro-mundanely push (obj place &environment env)
   #!+sb-doc
   "Takes an object and a location holding a list. Conses the object onto
   the list, returning the modified list. OBJ is evaluated before PLACE."
   (multiple-value-bind (dummies vals newval setter getter)
 
 (defmacro-mundanely push (obj place &environment env)
   #!+sb-doc
   "Takes an object and a location holding a list. Conses the object onto
   the list, returning the modified list. OBJ is evaluated before PLACE."
   (multiple-value-bind (dummies vals newval setter getter)

-      (get-setf-method place env)
+      (sb!xc:get-setf-expansion place env)

     (let ((g (gensym)))
       `(let* ((,g ,obj)
               ,@(mapcar #'list dummies vals)
     (let ((g (gensym)))
       `(let* ((,g ,obj)
               ,@(mapcar #'list dummies vals)

-              (,(car newval) (cons ,g ,getter)))
+              (,(car newval) (cons ,g ,getter))
+              ,@(cdr newval))

          ,setter))))
 
          ,setter))))
 

-(defmacro-mundanely pushnew (obj place &rest keys &environment env)
+(defmacro-mundanely pushnew (obj place &rest keys
+                             &key key test test-not &environment env)

   #!+sb-doc
   #!+sb-doc

-  "Takes an object and a location holding a list. If the object is already
-  in the list, does nothing. Else, conses the object onto the list. Returns
-  NIL. If there is a :TEST keyword, this is used for the comparison."
+  "Takes an object and a location holding a list. If the object is
+  already in the list, does nothing; otherwise, conses the object onto
+  the list. Returns the modified list. If there is a :TEST keyword, this
+  is used for the comparison."
+  (declare (ignore key test test-not))

   (multiple-value-bind (dummies vals newval setter getter)
   (multiple-value-bind (dummies vals newval setter getter)

-      (get-setf-method place env)
+      (sb!xc:get-setf-expansion place env)

     (let ((g (gensym)))
       `(let* ((,g ,obj)
               ,@(mapcar #'list dummies vals)
     (let ((g (gensym)))
       `(let* ((,g ,obj)
               ,@(mapcar #'list dummies vals)

-              (,(car newval) (adjoin ,g ,getter ,@keys)))
+              (,(car newval) (adjoin ,g ,getter ,@keys))
+              ,@(cdr newval))

          ,setter))))
 
 (defmacro-mundanely pop (place &environment env)
          ,setter))))
 
 (defmacro-mundanely pop (place &environment env)

@@ -212,17 +223,14 @@ GET-SETF-EXPANSION directly."
   "The argument is a location holding a list. Pops one item off the front
   of the list and returns it."
   (multiple-value-bind (dummies vals newval setter getter)
   "The argument is a location holding a list. Pops one item off the front
   of the list and returns it."
   (multiple-value-bind (dummies vals newval setter getter)

-      (get-setf-method place env)
-    (do* ((d dummies (cdr d))
-          (v vals (cdr v))
-          (let-list nil))
-         ((null d)
-          (push (list (car newval) getter) let-list)
-          `(let* ,(nreverse let-list)
-             (prog1 (car ,(car newval))
-               (setq ,(car newval) (cdr ,(car newval)))
-               ,setter)))
-      (push (list (car d) (car v)) let-list))))
+      (sb!xc:get-setf-expansion place env)
+    (let ((list-head (gensym)))
+      `(let* (,@(mapcar #'list dummies vals)
+              (,list-head ,getter)
+              (,(car newval) (cdr ,list-head))
+              ,@(cdr newval))
+         ,setter
+         (car ,list-head)))))

 
 (defmacro-mundanely remf (place indicator &environment env)
   #!+sb-doc
 
 (defmacro-mundanely remf (place indicator &environment env)
   #!+sb-doc

@@ -231,30 +239,54 @@ GET-SETF-EXPANSION directly."
   remove the property specified by the indicator. Returns T if such a
   property was present, NIL if not."
   (multiple-value-bind (dummies vals newval setter getter)
   remove the property specified by the indicator. Returns T if such a
   property was present, NIL if not."
   (multiple-value-bind (dummies vals newval setter getter)

-      (get-setf-method place env)
-    (do* ((d dummies (cdr d))
-         (v vals (cdr v))
-         (let-list nil)
-         (ind-temp (gensym))
-         (local1 (gensym))
-         (local2 (gensym)))
-        ((null d)
-         (push (list (car newval) getter) let-list)
-         (push (list ind-temp indicator) let-list)
-         `(let* ,(nreverse let-list)
-            (do ((,local1 ,(car newval) (cddr ,local1))
-                 (,local2 nil ,local1))
-                ((atom ,local1) nil)
-              (cond ((atom (cdr ,local1))
-                     (error "Odd-length property list in REMF."))
-                    ((eq (car ,local1) ,ind-temp)
-                     (cond (,local2
-                            (rplacd (cdr ,local2) (cddr ,local1))
-                            (return t))
-                           (t (setq ,(car newval) (cddr ,(car newval)))
-                              ,setter
-                              (return t))))))))
-      (push (list (car d) (car v)) let-list))))
+      (sb!xc:get-setf-expansion place env)
+    (let ((ind-temp (gensym))
+          (local1 (gensym))
+          (local2 (gensym)))
+      `(let* (,@(mapcar #'list dummies vals)
+              ;; See ANSI 5.1.3 for why we do out-of-order evaluation
+              (,ind-temp ,indicator)
+              (,(car newval) ,getter)
+              ,@(cdr newval))
+         (do ((,local1 ,(car newval) (cddr ,local1))
+              (,local2 nil ,local1))
+             ((atom ,local1) nil)
+             (cond ((atom (cdr ,local1))
+                    (error "Odd-length property list in REMF."))
+                   ((eq (car ,local1) ,ind-temp)
+                    (cond (,local2
+                           (rplacd (cdr ,local2) (cddr ,local1))
+                           (return t))
+                          (t (setq ,(car newval) (cddr ,(car newval)))
+                             ,setter
+                             (return t))))))))))
+
+;;; we can't use DEFINE-MODIFY-MACRO because of ANSI 5.1.3
+(defmacro-mundanely incf (place &optional (delta 1) &environment env)
+  #!+sb-doc
+  "The first argument is some location holding a number. This number is
+  incremented by the second argument, DELTA, which defaults to 1."
+  (multiple-value-bind (dummies vals newval setter getter)
+      (sb!xc:get-setf-expansion place env)
+    (let ((d (gensym)))
+      `(let* (,@(mapcar #'list dummies vals)
+              (,d ,delta)
+              (,(car newval) (+ ,getter ,d))
+              ,@(cdr newval))
+         ,setter))))
+
+(defmacro-mundanely decf (place &optional (delta 1) &environment env)
+  #!+sb-doc
+  "The first argument is some location holding a number. This number is
+  decremented by the second argument, DELTA, which defaults to 1."
+  (multiple-value-bind (dummies vals newval setter getter)
+      (sb!xc:get-setf-expansion place env)
+    (let ((d (gensym)))
+      `(let* (,@(mapcar #'list dummies vals)
+              (,d ,delta)
+              (,(car newval) (- ,getter ,d))
+              ,@(cdr newval))
+         ,setter))))

 \f
 ;;;; DEFINE-MODIFY-MACRO stuff
 
 \f
 ;;;; DEFINE-MODIFY-MACRO stuff
 

@@ -262,76 +294,70 @@ GET-SETF-EXPANSION directly."
   #!+sb-doc
   "Creates a new read-modify-write macro like PUSH or INCF."
   (let ((other-args nil)
   #!+sb-doc
   "Creates a new read-modify-write macro like PUSH or INCF."
   (let ((other-args nil)

-       (rest-arg nil)
-       (env (gensym))
-       (reference (gensym)))
+        (rest-arg nil)
+        (env (make-symbol "ENV"))          ; To beautify resulting arglist.
+        (reference (make-symbol "PLACE"))) ; Note that these will be nonexistent
+                                           ;  in the final expansion anyway.

     ;; Parse out the variable names and &REST arg from the lambda list.
     (do ((ll lambda-list (cdr ll))
     ;; Parse out the variable names and &REST arg from the lambda list.
     (do ((ll lambda-list (cdr ll))

-        (arg nil))
-       ((null ll))
+         (arg nil))
+        ((null ll))

       (setq arg (car ll))
       (cond ((eq arg '&optional))
       (setq arg (car ll))
       (cond ((eq arg '&optional))

-           ((eq arg '&rest)
-            (if (symbolp (cadr ll))
-              (setq rest-arg (cadr ll))
-              (error "Non-symbol &REST argument in definition of ~S." name))
-            (if (null (cddr ll))
-              (return nil)
-              (error "Illegal stuff after &REST argument.")))
-           ((memq arg '(&key &allow-other-keys &aux))
-            (error "~S not allowed in DEFINE-MODIFY-MACRO lambda list." arg))
-           ((symbolp arg)
-            (push arg other-args))
-           ((and (listp arg) (symbolp (car arg)))
-            (push (car arg) other-args))
-           (t (error "Illegal stuff in lambda list."))))
+            ((eq arg '&rest)
+             (if (symbolp (cadr ll))
+               (setq rest-arg (cadr ll))
+               (error "Non-symbol &REST argument in definition of ~S." name))
+             (if (null (cddr ll))
+               (return nil)
+               (error "Illegal stuff after &REST argument.")))
+            ((memq arg '(&key &allow-other-keys &aux))
+             (error "~S not allowed in DEFINE-MODIFY-MACRO lambda list." arg))
+            ((symbolp arg)
+             (push arg other-args))
+            ((and (listp arg) (symbolp (car arg)))
+             (push (car arg) other-args))
+            (t (error "Illegal stuff in lambda list."))))

     (setq other-args (nreverse other-args))
     `(#-sb-xc-host sb!xc:defmacro
       #+sb-xc-host defmacro-mundanely
     (setq other-args (nreverse other-args))
     `(#-sb-xc-host sb!xc:defmacro
       #+sb-xc-host defmacro-mundanely

-        ,name (,reference ,@lambda-list &environment ,env)
+         ,name (,reference ,@lambda-list &environment ,env)

        ,doc-string
        (multiple-value-bind (dummies vals newval setter getter)
        ,doc-string
        (multiple-value-bind (dummies vals newval setter getter)

-          (get-setf-method ,reference ,env)
-        (do ((d dummies (cdr d))
-             (v vals (cdr v))
-             (let-list nil (cons (list (car d) (car v)) let-list)))
-            ((null d)
-             (push (list (car newval)
-                         ,(if rest-arg
-                            `(list* ',function getter ,@other-args ,rest-arg)
-                            `(list ',function getter ,@other-args)))
-                   let-list)
-             `(let* ,(nreverse let-list)
-                ,setter)))))))
-
-(sb!xc:define-modify-macro incf (&optional (delta 1)) +
-  #!+sb-doc
-  "The first argument is some location holding a number. This number is
-  incremented by the second argument, DELTA, which defaults to 1.")
-
-(sb!xc:define-modify-macro decf (&optional (delta 1)) -
-  #!+sb-doc
-  "The first argument is some location holding a number. This number is
-  decremented by the second argument, DELTA, which defaults to 1.")
+           (sb!xc:get-setf-expansion ,reference ,env)
+         (let ()
+             `(let* (,@(mapcar #'list dummies vals)
+                     (,(car newval)
+                      ,,(if rest-arg
+                          `(list* ',function getter ,@other-args ,rest-arg)
+                          `(list ',function getter ,@other-args)))
+                     ,@(cdr newval))
+                ,setter))))))

 \f
 ;;;; DEFSETF
 
 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
   ;;; Assign SETF macro information for NAME, making all appropriate checks.
 \f
 ;;;; DEFSETF
 
 (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*)
     (cond ((gethash name sb!c:*setf-assumed-fboundp*)

-          (warn
-           "defining setf macro for ~S when ~S was previously ~
-            treated as a function"
-           name
-           `(setf ,name)))
-         ((not (fboundp `(setf ,name)))
-          ;; All is well, we don't need any warnings.
-          (values))
-         ((not (eq (symbol-package name) (symbol-package 'aref)))
-          (style-warn "defining setf macro for ~S when ~S is fbound"
-                      name `(setf ,name))))
+           (warn
+            "defining setf macro for ~S when ~S was previously ~
+             treated as a function"
+            name
+            `(setf ,name)))
+          ((not (fboundp `(setf ,name)))
+           ;; All is well, we don't need any warnings.
+           (values))
+          ((not (eq (symbol-package name) (symbol-package 'aref)))
+           (style-warn "defining setf macro for ~S when ~S is fbound"
+                       name `(setf ,name))))

     (remhash name sb!c:*setf-assumed-fboundp*)
     (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))
     ;; 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))

@@ -346,144 +372,148 @@ GET-SETF-EXPANSION directly."
   #!+sb-doc
   "Associates a SETF update function or macro with the specified access
   function or macro. The format is complex. See the manual for details."
   #!+sb-doc
   "Associates a SETF update function or macro with the specified access
   function or macro. The format is complex. See the manual for details."

-  (cond ((not (listp (car rest)))
-        `(eval-when (:load-toplevel :compile-toplevel :execute)
-           (assign-setf-macro ',access-fn
-                              nil
-                              ',(car rest)
-                               ,(when (and (car rest) (stringp (cadr rest)))
-                                  `',(cadr rest)))))
-       ((and (cdr rest) (listp (cadr rest)))
-        (destructuring-bind
-            (lambda-list (&rest store-variables) &body body)
-            rest
-          (let ((arglist-var (gensym "ARGS-"))
-                (access-form-var (gensym "ACCESS-FORM-"))
-                (env-var (gensym "ENVIRONMENT-")))
-            (multiple-value-bind (body local-decs doc)
-                (parse-defmacro `(,lambda-list ,@store-variables)
-                                arglist-var body access-fn 'defsetf
-                                :anonymousp t)
-              `(eval-when (:compile-toplevel :load-toplevel :execute)
-                 (assign-setf-macro
-                  ',access-fn
-                  (lambda (,access-form-var ,env-var)
-                    (declare (ignore ,env-var))
-                    (%defsetf ,access-form-var ,(length store-variables)
-                              (lambda (,arglist-var)
-                                ,@local-decs
-                                (block ,access-fn
-                                  ,body))))
-                  nil
-                  ',doc))))))
-       (t
-        (error "ill-formed DEFSETF for ~S" access-fn))))
+  (cond ((and (not (listp (car rest))) (symbolp (car rest)))
+         `(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)))))
+        ((and (cdr rest) (listp (cadr rest)))
+         (destructuring-bind
+             (lambda-list (&rest store-variables) &body body)
+             rest
+           (with-unique-names (whole access-form environment)
+             (multiple-value-bind (body local-decs doc)
+                 (parse-defmacro `(,lambda-list ,@store-variables)
+                                 whole body access-fn 'defsetf
+                                 :environment environment
+                                 :anonymousp t)
+               `(eval-when (:compile-toplevel :load-toplevel :execute)
+                  (assign-setf-macro
+                   ',access-fn
+                   (lambda (,access-form ,environment)
+                     ,@local-decs
+                     (%defsetf ,access-form ,(length store-variables)
+                               (lambda (,whole)
+                                 ,body)))
+                   ',lambda-list
+                   nil
+                   ',doc))))))
+        (t
+         (error "ill-formed DEFSETF for ~S" access-fn))))

 
 (defun %defsetf (orig-access-form num-store-vars expander)
   (declare (type function expander))
   (let (subforms
 
 (defun %defsetf (orig-access-form num-store-vars expander)
   (declare (type function expander))
   (let (subforms

-       subform-vars
-       subform-exprs
-       store-vars)
+        subform-vars
+        subform-exprs
+        store-vars)

     (dolist (subform (cdr orig-access-form))
       (if (constantp subform)
     (dolist (subform (cdr orig-access-form))
       (if (constantp subform)

-       (push subform subforms)
-       (let ((var (gensym)))
-         (push var subforms)
-         (push var subform-vars)
-         (push subform subform-exprs))))
+        (push subform subforms)
+        (let ((var (gensym)))
+          (push var subforms)
+          (push var subform-vars)
+          (push subform subform-exprs))))

     (dotimes (i num-store-vars)
       (push (gensym) store-vars))
     (let ((r-subforms (nreverse subforms))
     (dotimes (i num-store-vars)
       (push (gensym) store-vars))
     (let ((r-subforms (nreverse subforms))

-         (r-subform-vars (nreverse subform-vars))
-         (r-subform-exprs (nreverse subform-exprs))
-         (r-store-vars (nreverse store-vars)))
+          (r-subform-vars (nreverse subform-vars))
+          (r-subform-exprs (nreverse subform-exprs))
+          (r-store-vars (nreverse store-vars)))

       (values r-subform-vars
       (values r-subform-vars

-             r-subform-exprs
-             r-store-vars
-             (funcall expander (cons r-subforms r-store-vars))
-             `(,(car orig-access-form) ,@r-subforms)))))
+              r-subform-exprs
+              r-store-vars
+              (funcall expander (cons r-subforms r-store-vars))
+              `(,(car orig-access-form) ,@r-subforms)))))

 \f
 ;;;; DEFMACRO DEFINE-SETF-EXPANDER and various DEFINE-SETF-EXPANDERs
 
 ;;; DEFINE-SETF-EXPANDER is a lot like DEFMACRO.
 (def!macro sb!xc:define-setf-expander (access-fn lambda-list &body body)
   #!+sb-doc
 \f
 ;;;; DEFMACRO DEFINE-SETF-EXPANDER and various DEFINE-SETF-EXPANDERs
 
 ;;; DEFINE-SETF-EXPANDER is a lot like DEFMACRO.
 (def!macro sb!xc:define-setf-expander (access-fn lambda-list &body body)
   #!+sb-doc

-  "Syntax like DEFMACRO, but creates a Setf-Method generator. The body
-  must be a form that returns the five magical values."
+  "Syntax like DEFMACRO, but creates a setf expander function. The body
+  of the definition must be a form that returns five appropriate values."

   (unless (symbolp access-fn)
   (unless (symbolp access-fn)

-    (error "DEFINE-SETF-EXPANDER access-function name ~S is not a symbol."
-          access-fn))
-  (let ((whole (gensym "WHOLE-"))
-       (environment (gensym "ENV-")))
+    (error "~S access-function name ~S is not a symbol."
+           'sb!xc:define-setf-expander access-fn))
+  (with-unique-names (whole environment)

     (multiple-value-bind (body local-decs doc)
     (multiple-value-bind (body local-decs doc)

-       (parse-defmacro lambda-list whole body access-fn
-                       'sb!xc:define-setf-expander
-                       :environment environment)
+        (parse-defmacro lambda-list whole body access-fn
+                        'sb!xc:define-setf-expander
+                        :environment environment)

       `(eval-when (:compile-toplevel :load-toplevel :execute)
       `(eval-when (:compile-toplevel :load-toplevel :execute)

-        (assign-setf-macro ',access-fn
-                           (lambda (,whole ,environment)
-                             ,@local-decs
-                             (block ,access-fn ,body))
-                           nil
-                           ',doc)))))
+         (assign-setf-macro ',access-fn
+                            (lambda (,whole ,environment)
+                              ,@local-decs
+                              ,body)
+                            ',lambda-list
+                            nil
+                            ',doc)))))

 
 (sb!xc:define-setf-expander getf (place prop
 
 (sb!xc:define-setf-expander getf (place prop

-                                 &optional default
-                                 &environment env)
+                                  &optional default
+                                  &environment env)

   (declare (type sb!c::lexenv env))
   (multiple-value-bind (temps values stores set get)
   (declare (type sb!c::lexenv env))
   (multiple-value-bind (temps values stores set get)

-      (get-setf-method place env)
+      (sb!xc:get-setf-expansion place env)

     (let ((newval (gensym))
     (let ((newval (gensym))

-         (ptemp (gensym))
-         (def-temp (if default (gensym))))
+          (ptemp (gensym))
+          (def-temp (if default (gensym))))

       (values `(,@temps ,ptemp ,@(if default `(,def-temp)))
       (values `(,@temps ,ptemp ,@(if default `(,def-temp)))

-             `(,@values ,prop ,@(if default `(,default)))
-             `(,newval)
-             `(let ((,(car stores) (%putf ,get ,ptemp ,newval)))
-                ,set
-                ,newval)
-             `(getf ,get ,ptemp ,@(if default `(,def-temp)))))))
+              `(,@values ,prop ,@(if default `(,default)))
+              `(,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)))))))

 
 (sb!xc:define-setf-expander get (symbol prop &optional default)
   (let ((symbol-temp (gensym))
 
 (sb!xc:define-setf-expander get (symbol prop &optional default)
   (let ((symbol-temp (gensym))

-       (prop-temp (gensym))
-       (def-temp (gensym))
-       (newval (gensym)))
+        (prop-temp (gensym))
+        (def-temp (if default (gensym)))
+        (newval (gensym)))

     (values `(,symbol-temp ,prop-temp ,@(if default `(,def-temp)))
     (values `(,symbol-temp ,prop-temp ,@(if default `(,def-temp)))

-           `(,symbol ,prop ,@(if default `(,default)))
-           (list newval)
-           `(%put ,symbol-temp ,prop-temp ,newval)
-           `(get ,symbol-temp ,prop-temp ,@(if default `(,def-temp))))))
+            `(,symbol ,prop ,@(if default `(,default)))
+            (list 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))
 
 (sb!xc:define-setf-expander gethash (key hashtable &optional default)
   (let ((key-temp (gensym))

-       (hashtable-temp (gensym))
-       (default-temp (gensym))
-       (new-value-temp (gensym)))
+        (hashtable-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)
     (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)
   (declare (type sb!c::lexenv env))
   (multiple-value-bind (temps vals stores store-form access-form)
      `(gethash ,key-temp ,hashtable-temp ,@(if default `(,default-temp))))))
 
 (sb!xc:define-setf-expander logbitp (index int &environment env)
   (declare (type sb!c::lexenv env))
   (multiple-value-bind (temps vals stores store-form access-form)

-      (get-setf-method int env)
+      (sb!xc:get-setf-expansion int env)

     (let ((ind (gensym))
     (let ((ind (gensym))

-         (store (gensym))
-         (stemp (first stores)))
+          (store (gensym))
+          (stemp (first stores)))

       (values `(,ind ,@temps)
       (values `(,ind ,@temps)

-             `(,index
-               ,@vals)
-             (list store)
-             `(let ((,stemp
-                     (dpb (if ,store 1 0) (byte 1 ,ind) ,access-form)))
-                ,store-form
-                ,store)
-             `(logbitp ,ind ,access-form)))))
+              `(,index
+                ,@vals)
+              (list store)
+              `(let ((,stemp
+                      (dpb (if ,store 1 0) (byte 1 ,ind) ,access-form))
+                     ,@(cdr stores))
+                 ,store-form
+                 ,store)
+              `(logbitp ,ind ,access-form)))))

 
 ;;; CMU CL had a comment here that:
 ;;;   Evil hack invented by the gnomes of Vassar Street (though not as evil as
 
 ;;; CMU CL had a comment here that:
 ;;;   Evil hack invented by the gnomes of Vassar Street (though not as evil as

@@ -496,16 +526,16 @@ GET-SETF-EXPANSION directly."
 ;;; ANSI has some place for SETF APPLY. -- WHN 19990604
 (sb!xc:define-setf-expander apply (functionoid &rest args)
   (unless (and (listp functionoid)
 ;;; ANSI has some place for SETF APPLY. -- WHN 19990604
 (sb!xc:define-setf-expander apply (functionoid &rest args)
   (unless (and (listp functionoid)

-              (= (length functionoid) 2)
-              (eq (first functionoid) 'function)
-              (symbolp (second functionoid)))
+               (= (length functionoid) 2)
+               (eq (first functionoid) 'function)
+               (symbolp (second functionoid)))

     (error "SETF of APPLY is only defined for function args like #'SYMBOL."))
   (let ((function (second functionoid))
     (error "SETF of APPLY is only defined for function args like #'SYMBOL."))
   (let ((function (second functionoid))

-       (new-var (gensym))
-       (vars (make-gensym-list (length args))))
+        (new-var (gensym))
+        (vars (make-gensym-list (length args))))

     (values vars args (list new-var)
     (values vars args (list new-var)

-           `(apply #'(setf ,function) ,new-var ,@vars)
-           `(apply #',function ,@vars))))
+            `(apply #'(setf ,function) ,new-var ,@vars)
+            `(apply #',function ,@vars))))

 
 ;;; Special-case a BYTE bytespec so that the compiler can recognize it.
 (sb!xc:define-setf-expander ldb (bytespec place &environment env)
 
 ;;; Special-case a BYTE bytespec so that the compiler can recognize it.
 (sb!xc:define-setf-expander ldb (bytespec place &environment env)

@@ -515,28 +545,29 @@ GET-SETF-EXPANSION directly."
   place with bits from the low-order end of the new value."
   (declare (type sb!c::lexenv env))
   (multiple-value-bind (dummies vals newval setter getter)
   place with bits from the low-order end of the new value."
   (declare (type sb!c::lexenv env))
   (multiple-value-bind (dummies vals newval setter getter)

-      (get-setf-method place env)
+      (sb!xc:get-setf-expansion place env)

     (if (and (consp bytespec) (eq (car bytespec) 'byte))
     (if (and (consp bytespec) (eq (car bytespec) 'byte))

-       (let ((n-size (gensym))
-             (n-pos (gensym))
-             (n-new (gensym)))
-         (values (list* n-size n-pos dummies)
-                 (list* (second bytespec) (third bytespec) vals)
-                 (list n-new)
-                 `(let ((,(car newval) (dpb ,n-new (byte ,n-size ,n-pos)
-                                            ,getter)))
-                    ,setter
-                    ,n-new)
-                 `(ldb (byte ,n-size ,n-pos) ,getter)))
-       (let ((btemp (gensym))
-             (gnuval (gensym)))
-         (values (cons btemp dummies)
-                 (cons bytespec vals)
-                 (list gnuval)
-                 `(let ((,(car newval) (dpb ,gnuval ,btemp ,getter)))
-                    ,setter
-                    ,gnuval)
-                 `(ldb ,btemp ,getter))))))
+        (let ((n-size (gensym))
+              (n-pos (gensym))
+              (n-new (gensym)))
+          (values (list* n-size n-pos dummies)
+                  (list* (second bytespec) (third bytespec) vals)
+                  (list n-new)
+                  `(let ((,(car newval) (dpb ,n-new (byte ,n-size ,n-pos)
+                                             ,getter))
+                         ,@(cdr newval))
+                     ,setter
+                     ,n-new)
+                  `(ldb (byte ,n-size ,n-pos) ,getter)))
+        (let ((btemp (gensym))
+              (gnuval (gensym)))
+          (values (cons btemp dummies)
+                  (cons bytespec vals)
+                  (list gnuval)
+                  `(let ((,(car newval) (dpb ,gnuval ,btemp ,getter)))
+                     ,setter
+                     ,gnuval)
+                  `(ldb ,btemp ,getter))))))

 
 (sb!xc:define-setf-expander mask-field (bytespec place &environment env)
   #!+sb-doc
 
 (sb!xc:define-setf-expander mask-field (bytespec place &environment env)
   #!+sb-doc

@@ -545,23 +576,30 @@ GET-SETF-EXPANSION directly."
   with bits from the corresponding position in the new value."
   (declare (type sb!c::lexenv env))
   (multiple-value-bind (dummies vals newval setter getter)
   with bits from the corresponding position in the new value."
   (declare (type sb!c::lexenv env))
   (multiple-value-bind (dummies vals newval setter getter)

-      (get-setf-method place env)
+      (sb!xc:get-setf-expansion place env)

     (let ((btemp (gensym))
     (let ((btemp (gensym))

-         (gnuval (gensym)))
+          (gnuval (gensym)))

       (values (cons btemp dummies)
       (values (cons btemp dummies)

-             (cons bytespec vals)
-             (list gnuval)
-             `(let ((,(car newval) (deposit-field ,gnuval ,btemp ,getter)))
-                ,setter
-                ,gnuval)
-             `(mask-field ,btemp ,getter)))))
+              (cons bytespec vals)
+              (list gnuval)
+              `(let ((,(car newval) (deposit-field ,gnuval ,btemp ,getter))
+                     ,@(cdr newval))
+                 ,setter
+                 ,gnuval)
+              `(mask-field ,btemp ,getter)))))

 
 

-(sb!xc:define-setf-expander the (type place &environment env)
+(defun setf-expand-the (the type place env)

   (declare (type sb!c::lexenv env))
   (declare (type sb!c::lexenv env))

-  (multiple-value-bind (dummies vals newval setter getter)
-      (get-setf-method place env)
-    (values dummies
-             vals
-             newval
-             (subst `(the ,type ,(car newval)) (car newval) setter)
-             `(the ,type ,getter))))
+  (multiple-value-bind (temps subforms store-vars setter getter)
+      (sb!xc:get-setf-expansion place env)
+    (values temps subforms store-vars
+            `(multiple-value-bind ,store-vars
+                 (,the ,type (values ,@store-vars))
+               ,setter)
+            `(,the ,type ,getter))))
+
+(sb!xc:define-setf-expander the (type place &environment env)
+  (setf-expand-the 'the type place env))
+
+(sb!xc:define-setf-expander truly-the (type place &environment env)
+  (setf-expand-the 'truly-the type place env))