Simplify (and robustify) regular PACKing

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

diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp
index 7fe66bb..74a3a43 100644 (file)
--- a/src/code/early-setf.lisp
+++ b/src/code/early-setf.lisp
@@ -70,25 +70,6 @@
           (t
            (expand-or-get-setf-inverse form 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)))
-

 ;;; 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)))
 ;;; 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
       (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)))))
                (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.
 
 (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*)
     (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*)
            (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))
     ;; 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
          `(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)))))
                                ',(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)))
                      (%defsetf ,access-form ,(length store-variables)
                                (lambda (,whole)
                                  ,body)))

+                   ',lambda-list

                    nil
                    ',doc))))))
         (t
                    nil
                    ',doc))))))
         (t

@@ -462,6 +449,7 @@ GET-SETF-EXPANSION directly."
                             (lambda (,whole ,environment)
                               ,@local-decs
                               ,body)
                             (lambda (,whole ,environment)
                               ,@local-decs
                               ,body)

+                            ',lambda-list

                             nil
                             ',doc)))))
 
                             nil
                             ',doc)))))
 

@@ -470,14 +458,16 @@ GET-SETF-EXPANSION directly."
                                   &environment env)
   (declare (type sb!c::lexenv env))
   (multiple-value-bind (temps values stores set get)
                                   &environment env)
   (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))
           (ptemp (gensym))
           (def-temp (if default (gensym))))
       (values `(,@temps ,ptemp ,@(if default `(,def-temp)))
               `(,@values ,prop ,@(if default `(,default)))
               `(,newval)
     (let ((newval (gensym))
           (ptemp (gensym))
           (def-temp (if default (gensym))))
       (values `(,@temps ,ptemp ,@(if default `(,def-temp)))
               `(,@values ,prop ,@(if default `(,default)))
               `(,newval)

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

@@ -485,30 +475,32 @@ GET-SETF-EXPANSION directly."
 (sb!xc:define-setf-expander get (symbol prop &optional default)
   (let ((symbol-temp (gensym))
         (prop-temp (gensym))
 (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)
         (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))
             `(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)
         (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)
   (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))
           (store (gensym))
           (stemp (first stores)))
     (let ((ind (gensym))
           (store (gensym))
           (stemp (first stores)))

@@ -517,7 +509,8 @@ GET-SETF-EXPANSION directly."
                 ,@vals)
               (list store)
               `(let ((,stemp
                 ,@vals)
               (list store)
               `(let ((,stemp

-                      (dpb (if ,store 1 0) (byte 1 ,ind) ,access-form)))
+                      (dpb (if ,store 1 0) (byte 1 ,ind) ,access-form))
+                     ,@(cdr stores))

                  ,store-form
                  ,store)
               `(logbitp ,ind ,access-form)))))
                  ,store-form
                  ,store)
               `(logbitp ,ind ,access-form)))))

@@ -548,11 +541,11 @@ GET-SETF-EXPANSION directly."
 (sb!xc:define-setf-expander ldb (bytespec place &environment env)
   #!+sb-doc
   "The first argument is a byte specifier. The second is any place form
 (sb!xc:define-setf-expander ldb (bytespec place &environment env)
   #!+sb-doc
   "The first argument is a byte specifier. The second is any place form

-  acceptable to SETF. Replace the specified byte of the number in this
-  place with bits from the low-order end of the new value."
+acceptable to SETF. Replace the specified byte of the number in this
+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)
   (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))
         (let ((n-size (gensym))
               (n-pos (gensym))
     (if (and (consp bytespec) (eq (car bytespec) 'byte))
         (let ((n-size (gensym))
               (n-pos (gensym))

@@ -561,7 +554,8 @@ GET-SETF-EXPANSION directly."
                   (list* (second bytespec) (third bytespec) vals)
                   (list n-new)
                   `(let ((,(car newval) (dpb ,n-new (byte ,n-size ,n-pos)
                   (list* (second bytespec) (third bytespec) vals)
                   (list n-new)
                   `(let ((,(car newval) (dpb ,n-new (byte ,n-size ,n-pos)

-                                             ,getter)))
+                                             ,getter))
+                         ,@(cdr newval))

                      ,setter
                      ,n-new)
                   `(ldb (byte ,n-size ,n-pos) ,getter)))
                      ,setter
                      ,n-new)
                   `(ldb (byte ,n-size ,n-pos) ,getter)))

@@ -578,17 +572,18 @@ GET-SETF-EXPANSION directly."
 (sb!xc:define-setf-expander mask-field (bytespec place &environment env)
   #!+sb-doc
   "The first argument is a byte specifier. The second is any place form
 (sb!xc:define-setf-expander mask-field (bytespec place &environment env)
   #!+sb-doc
   "The first argument is a byte specifier. The second is any place form

-  acceptable to SETF. Replaces the specified byte of the number in this place
-  with bits from the corresponding position in the new value."
+acceptable to SETF. Replaces the specified byte of the number in this place
+with bits from the corresponding position in the new value."

   (declare (type sb!c::lexenv env))
   (multiple-value-bind (dummies vals newval setter getter)
   (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))
           (gnuval (gensym)))
       (values (cons btemp dummies)
               (cons bytespec vals)
               (list gnuval)
     (let ((btemp (gensym))
           (gnuval (gensym)))
       (values (cons btemp dummies)
               (cons bytespec vals)
               (list gnuval)

-              `(let ((,(car newval) (deposit-field ,gnuval ,btemp ,getter)))
+              `(let ((,(car newval) (deposit-field ,gnuval ,btemp ,getter))
+                     ,@(cdr newval))

                  ,setter
                  ,gnuval)
               `(mask-field ,btemp ,getter)))))
                  ,setter
                  ,gnuval)
               `(mask-field ,btemp ,getter)))))