src/code/early-setf.lisp

   1 ;;;; SETF and friends (except for stuff defined with COLLECT, which
   2 ;;;; comes later)
   3 ;;;;
   4 ;;;; Note: The expansions for SETF and friends sometimes create
   5 ;;;; needless LET-bindings of argument values. The compiler will
   6 ;;;; remove most of these spurious bindings, so SETF doesn't worry too
   7 ;;;; much about creating them.
   8
   9 ;;;; This software is part of the SBCL system. See the README file for
  10 ;;;; more information.
  11 ;;;;
  12 ;;;; This software is derived from the CMU CL system, which was
  13 ;;;; written at Carnegie Mellon University and released into the
  14 ;;;; public domain. The software is in the public domain and is
  15 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  16 ;;;; files for more information.
  17
  18 (in-package "SB!IMPL")
  19
  20 ;;; The inverse for a generalized-variable reference function is stored in
  21 ;;; one of two ways:
  22 ;;;
  23 ;;; A SETF inverse property corresponds to the short form of DEFSETF. It is
  24 ;;; the name of a function takes the same args as the reference form, plus a
  25 ;;; new-value arg at the end.
  26 ;;;
  27 ;;; A SETF method expander is created by the long form of DEFSETF or
  28 ;;; by DEFINE-SETF-EXPANDER. It is a function that is called on the reference
  29 ;;; form and that produces five values: a list of temporary variables, a list
  30 ;;; of value forms, a list of the single store-value form, a storing function,
  31 ;;; and an accessing function.
  32 (declaim (ftype (function (t &optional (or null sb!c::lexenv))) sb!xc:get-setf-expansion))
  33 (defun sb!xc:get-setf-expansion (form &optional environment)
  34   #!+sb-doc
  35   "Return five values needed by the SETF machinery: a list of temporary
  36    variables, a list of values with which to fill them, a list of temporaries
  37    for the new values, the setting function, and the accessing function."
  38   (let (temp)
  39     (cond ((symbolp form)
  40            (multiple-value-bind (expansion expanded)
  41                (%macroexpand-1 form environment)
  42              (if expanded
  43                  (sb!xc:get-setf-expansion expansion environment)
  44                  (let ((new-var (sb!xc:gensym "NEW")))
  45                    (values nil nil (list new-var)
  46                            `(setq ,form ,new-var) form)))))
  47           ;; Local functions inhibit global SETF methods.
  48           ((and environment
  49                 (let ((name (car form)))
  50                   (dolist (x (sb!c::lexenv-funs environment))
  51                     (when (and (eq (car x) name)
  52                                (not (sb!c::defined-fun-p (cdr x))))
  53                       (return t)))))
  54            (expand-or-get-setf-inverse form environment))
  55           ((setq temp (info :setf :inverse (car form)))
  56            (get-setf-method-inverse form `(,temp) nil environment))
  57           ((setq temp (info :setf :expander (car form)))
  58            ;; KLUDGE: It may seem as though this should go through
  59            ;; *MACROEXPAND-HOOK*, but the ANSI spec seems fairly explicit
  60            ;; that *MACROEXPAND-HOOK* is a hook for MACROEXPAND-1, not
  61            ;; for macroexpansion in general. -- WHN 19991128
  62            (funcall temp
  63                     form
  64                     ;; As near as I can tell from the ANSI spec,
  65                     ;; macroexpanders have a right to expect an actual
  66                     ;; lexical environment, not just a NIL which is to
  67                     ;; be interpreted as a null lexical environment.
  68                     ;; -- WHN 19991128
  69                     (coerce-to-lexenv environment)))
  70           (t
  71            (expand-or-get-setf-inverse form environment)))))
  72
  73 ;;; If a macro, expand one level and try again. If not, go for the
  74 ;;; SETF function.
  75 (declaim (ftype (function (t (or null sb!c::lexenv)))
  76                 expand-or-get-setf-inverse))
  77 (defun expand-or-get-setf-inverse (form environment)
  78   (multiple-value-bind (expansion expanded)
  79       (%macroexpand-1 form environment)
  80     (if expanded
  81         (sb!xc:get-setf-expansion expansion environment)
  82         (get-setf-method-inverse form
  83                                  `(funcall #'(setf ,(car form)))
  84                                  t
  85                                  environment))))
  86
  87 (defun get-setf-method-inverse (form inverse setf-fun environment)
  88   (let ((new-var (sb!xc:gensym "NEW"))
  89         (vars nil)
  90         (vals nil)
  91         (args nil))
  92     (dolist (x (reverse (cdr form)))
  93       (cond ((sb!xc:constantp x environment)
  94              (push x args))
  95             (t
  96              (let ((temp (gensymify x)))
  97                (push temp args)
  98                (push temp vars)
  99                (push x vals)))))
 100     (values vars
 101             vals
 102             (list new-var)
 103             (if setf-fun
 104                 `(,@inverse ,new-var ,@args)
 105                 `(,@inverse ,@args ,new-var))
 106             `(,(car form) ,@args))))
 107 \f
 108 ;;;; SETF itself
 109
 110 ;;; Except for atoms, we always call GET-SETF-EXPANSION, since it has
 111 ;;; some non-trivial semantics. But when there is a setf inverse, and
 112 ;;; G-S-E uses it, then we return a call to the inverse, rather than
 113 ;;; returning a hairy LET form. This is probably important mainly as a
 114 ;;; convenience in allowing the use of SETF inverses without the full
 115 ;;; interpreter.
 116 (defmacro-mundanely setf (&rest args &environment env)
 117   #!+sb-doc
 118   "Takes pairs of arguments like SETQ. The first is a place and the second
 119   is the value that is supposed to go into that place. Returns the last
 120   value. The place argument may be any of the access forms for which SETF
 121   knows a corresponding setting form."
 122   (let ((nargs (length args)))
 123     (cond
 124      ((= nargs 2)
 125       (let ((place (first args))
 126             (value-form (second args)))
 127         (if (atom place)
 128           `(setq ,place ,value-form)
 129           (multiple-value-bind (dummies vals newval setter getter)
 130               (sb!xc:get-setf-expansion place env)
 131             (declare (ignore getter))
 132             (let ((inverse (info :setf :inverse (car place))))
 133               (if (and inverse (eq inverse (car setter)))
 134                 `(,inverse ,@(cdr place) ,value-form)
 135                 `(let* (,@(mapcar #'list dummies vals))
 136                    (multiple-value-bind ,newval ,value-form
 137                      ,setter))))))))
 138      ((oddp nargs)
 139       (error "odd number of args to SETF"))
 140      (t
 141       (do ((a args (cddr a))
 142            (reversed-setfs nil))
 143           ((null a)
 144            `(progn ,@(nreverse reversed-setfs)))
 145         (push (list 'setf (car a) (cadr a)) reversed-setfs))))))
 146 \f
 147 ;;;; various SETF-related macros
 148
 149 (defmacro-mundanely shiftf (&whole form &rest args &environment env)
 150   #!+sb-doc
 151   "One or more SETF-style place expressions, followed by a single
 152    value expression. Evaluates all of the expressions in turn, then
 153    assigns the value of each expression to the place on its left,
 154    returning the value of the leftmost."
 155   (when (< (length args) 2)
 156     (error "~S called with too few arguments: ~S" 'shiftf form))
 157   (let (let*-bindings mv-bindings setters getters)
 158     (dolist (arg (butlast args))
 159       (multiple-value-bind (temps subforms store-vars setter getter)
 160           (sb!xc:get-setf-expansion arg env)
 161         (mapc (lambda (tmp form)
 162                 (push `(,tmp ,form) let*-bindings))
 163               temps
 164               subforms)
 165         (push store-vars mv-bindings)
 166         (push setter setters)
 167         (push getter getters)))
 168     ;; Handle the last arg specially here. The getter is just the last
 169     ;; arg itself.
 170     (push (car (last args)) getters)
 171
 172     ;; Reverse the collected lists so last bit looks nicer.
 173     (setf let*-bindings (nreverse let*-bindings)
 174           mv-bindings (nreverse mv-bindings)
 175           setters (nreverse setters)
 176           getters (nreverse getters))
 177
 178     (labels ((thunk (mv-bindings getters)
 179                (if mv-bindings
 180                    `((multiple-value-bind
 181                            ,(car mv-bindings)
 182                          ,(car getters)
 183                        ,@(thunk (cdr mv-bindings) (cdr getters))))
 184                    `(,@setters))))
 185       `(let ,let*-bindings
 186         (multiple-value-bind ,(car mv-bindings)
 187             ,(car getters)
 188           ,@(thunk mv-bindings (cdr getters))
 189           (values ,@(car mv-bindings)))))))
 190
 191 (defmacro-mundanely push (obj place &environment env)
 192   #!+sb-doc
 193   "Takes an object and a location holding a list. Conses the object onto
 194   the list, returning the modified list. OBJ is evaluated before PLACE."
 195   (multiple-value-bind (dummies vals newval setter getter)
 196       (sb!xc:get-setf-expansion place env)
 197     (let ((g (gensym)))
 198       `(let* ((,g ,obj)
 199               ,@(mapcar #'list dummies vals)
 200               (,(car newval) (cons ,g ,getter))
 201               ,@(cdr newval))
 202          ,setter))))
 203
 204 (defmacro-mundanely pushnew (obj place &rest keys
 205                              &key key test test-not &environment env)
 206   #!+sb-doc
 207   "Takes an object and a location holding a list. If the object is
 208   already in the list, does nothing; otherwise, conses the object onto
 209   the list. Returns the modified list. If there is a :TEST keyword, this
 210   is used for the comparison."
 211   (declare (ignore key test test-not))
 212   (multiple-value-bind (dummies vals newval setter getter)
 213       (sb!xc:get-setf-expansion place env)
 214     (let ((g (gensym)))
 215       `(let* ((,g ,obj)
 216               ,@(mapcar #'list dummies vals)
 217               (,(car newval) (adjoin ,g ,getter ,@keys))
 218               ,@(cdr newval))
 219          ,setter))))
 220
 221 (defmacro-mundanely pop (place &environment env)
 222   #!+sb-doc
 223   "The argument is a location holding a list. Pops one item off the front
 224   of the list and returns it."
 225   (multiple-value-bind (dummies vals newval setter getter)
 226       (sb!xc:get-setf-expansion place env)
 227     (let ((list-head (gensym)))
 228       `(let* (,@(mapcar #'list dummies vals)
 229               (,list-head ,getter)
 230               (,(car newval) (cdr ,list-head))
 231               ,@(cdr newval))
 232          ,setter
 233          (car ,list-head)))))
 234
 235 (defmacro-mundanely remf (place indicator &environment env)
 236   #!+sb-doc
 237   "Place may be any place expression acceptable to SETF, and is expected
 238   to hold a property list or (). This list is destructively altered to
 239   remove the property specified by the indicator. Returns T if such a
 240   property was present, NIL if not."
 241   (multiple-value-bind (dummies vals newval setter getter)
 242       (sb!xc:get-setf-expansion place env)
 243     (let ((ind-temp (gensym))
 244           (local1 (gensym))
 245           (local2 (gensym)))
 246       `(let* (,@(mapcar #'list dummies vals)
 247               ;; See ANSI 5.1.3 for why we do out-of-order evaluation
 248               (,ind-temp ,indicator)
 249               (,(car newval) ,getter)
 250               ,@(cdr newval))
 251          (do ((,local1 ,(car newval) (cddr ,local1))
 252               (,local2 nil ,local1))
 253              ((atom ,local1) nil)
 254              (cond ((atom (cdr ,local1))
 255                     (error "Odd-length property list in REMF."))
 256                    ((eq (car ,local1) ,ind-temp)
 257                     (cond (,local2
 258                            (rplacd (cdr ,local2) (cddr ,local1))
 259                            (return t))
 260                           (t (setq ,(car newval) (cddr ,(car newval)))
 261                              ,setter
 262                              (return t))))))))))
 263
 264 ;;; we can't use DEFINE-MODIFY-MACRO because of ANSI 5.1.3
 265 (defmacro-mundanely incf (place &optional (delta 1) &environment env)
 266   #!+sb-doc
 267   "The first argument is some location holding a number. This number is
 268   incremented by the second argument, DELTA, which defaults to 1."
 269   (multiple-value-bind (dummies vals newval setter getter)
 270       (sb!xc:get-setf-expansion place env)
 271     (let ((d (gensym)))
 272       `(let* (,@(mapcar #'list dummies vals)
 273               (,d ,delta)
 274               (,(car newval) (+ ,getter ,d))
 275               ,@(cdr newval))
 276          ,setter))))
 277
 278 (defmacro-mundanely decf (place &optional (delta 1) &environment env)
 279   #!+sb-doc
 280   "The first argument is some location holding a number. This number is
 281   decremented by the second argument, DELTA, which defaults to 1."
 282   (multiple-value-bind (dummies vals newval setter getter)
 283       (sb!xc:get-setf-expansion place env)
 284     (let ((d (gensym)))
 285       `(let* (,@(mapcar #'list dummies vals)
 286               (,d ,delta)
 287               (,(car newval) (- ,getter ,d))
 288               ,@(cdr newval))
 289          ,setter))))
 290 \f
 291 ;;;; DEFINE-MODIFY-MACRO stuff
 292
 293 (def!macro sb!xc:define-modify-macro (name lambda-list function &optional doc-string)
 294   #!+sb-doc
 295   "Creates a new read-modify-write macro like PUSH or INCF."
 296   (let ((other-args nil)
 297         (rest-arg nil)
 298         (env (make-symbol "ENV"))          ; To beautify resulting arglist.
 299         (reference (make-symbol "PLACE"))) ; Note that these will be nonexistent
 300                                            ;  in the final expansion anyway.
 301     ;; Parse out the variable names and &REST arg from the lambda list.
 302     (do ((ll lambda-list (cdr ll))
 303          (arg nil))
 304         ((null ll))
 305       (setq arg (car ll))
 306       (cond ((eq arg '&optional))
 307             ((eq arg '&rest)
 308              (if (symbolp (cadr ll))
 309                (setq rest-arg (cadr ll))
 310                (error "Non-symbol &REST argument in definition of ~S." name))
 311              (if (null (cddr ll))
 312                (return nil)
 313                (error "Illegal stuff after &REST argument.")))
 314             ((memq arg '(&key &allow-other-keys &aux))
 315              (error "~S not allowed in DEFINE-MODIFY-MACRO lambda list." arg))
 316             ((symbolp arg)
 317              (push arg other-args))
 318             ((and (listp arg) (symbolp (car arg)))
 319              (push (car arg) other-args))
 320             (t (error "Illegal stuff in lambda list."))))
 321     (setq other-args (nreverse other-args))
 322     `(#-sb-xc-host sb!xc:defmacro
 323       #+sb-xc-host defmacro-mundanely
 324          ,name (,reference ,@lambda-list &environment ,env)
 325        ,doc-string
 326        (multiple-value-bind (dummies vals newval setter getter)
 327            (sb!xc:get-setf-expansion ,reference ,env)
 328          (let ()
 329              `(let* (,@(mapcar #'list dummies vals)
 330                      (,(car newval)
 331                       ,,(if rest-arg
 332                           `(list* ',function getter ,@other-args ,rest-arg)
 333                           `(list ',function getter ,@other-args)))
 334                      ,@(cdr newval))
 335                 ,setter))))))
 336 \f
 337 ;;;; DEFSETF
 338
 339 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 340   ;;; Assign SETF macro information for NAME, making all appropriate checks.
 341   (defun assign-setf-macro (name expander expander-lambda-list inverse doc)
 342     #+sb-xc-host (declare (ignore expander-lambda-list))
 343     (with-single-package-locked-error
 344         (:symbol name "defining a setf-expander for ~A"))
 345     (cond ((gethash name sb!c:*setf-assumed-fboundp*)
 346            (warn
 347             "defining setf macro for ~S when ~S was previously ~
 348              treated as a function"
 349             name
 350             `(setf ,name)))
 351           ((not (fboundp `(setf ,name)))
 352            ;; All is well, we don't need any warnings.
 353            (values))
 354           ((not (eq (symbol-package name) (symbol-package 'aref)))
 355            (style-warn "defining setf macro for ~S when ~S is fbound"
 356                        name `(setf ,name))))
 357     (remhash name sb!c:*setf-assumed-fboundp*)
 358     #-sb-xc-host
 359     (when expander
 360       (setf (%fun-lambda-list expander) expander-lambda-list))
 361     ;; FIXME: It's probably possible to join these checks into one form which
 362     ;; is appropriate both on the cross-compilation host and on the target.
 363     (when (or inverse (info :setf :inverse name))
 364       (setf (info :setf :inverse name) inverse))
 365     (when (or expander (info :setf :expander name))
 366       (setf (info :setf :expander name) expander))
 367     (when doc
 368       (setf (fdocumentation name 'setf) doc))
 369     name))
 370
 371 (def!macro sb!xc:defsetf (access-fn &rest rest)
 372   #!+sb-doc
 373   "Associates a SETF update function or macro with the specified access
 374   function or macro. The format is complex. See the manual for details."
 375   (cond ((and (not (listp (car rest))) (symbolp (car rest)))
 376          `(eval-when (:load-toplevel :compile-toplevel :execute)
 377             (assign-setf-macro ',access-fn
 378                                nil
 379                                nil
 380                                ',(car rest)
 381                                 ,(when (and (car rest) (stringp (cadr rest)))
 382                                    `',(cadr rest)))))
 383         ((and (cdr rest) (listp (cadr rest)))
 384          (destructuring-bind
 385              (lambda-list (&rest store-variables) &body body)
 386              rest
 387            (with-unique-names (whole access-form environment)
 388              (multiple-value-bind (body local-decs doc)
 389                  (parse-defmacro `(,lambda-list ,@store-variables)
 390                                  whole body access-fn 'defsetf
 391                                  :environment environment
 392                                  :anonymousp t)
 393                `(eval-when (:compile-toplevel :load-toplevel :execute)
 394                   (assign-setf-macro
 395                    ',access-fn
 396                    (lambda (,access-form ,environment)
 397                      ,@local-decs
 398                      (%defsetf ,access-form ,(length store-variables)
 399                                (lambda (,whole)
 400                                  ,body)))
 401                    ',lambda-list
 402                    nil
 403                    ',doc))))))
 404         (t
 405          (error "ill-formed DEFSETF for ~S" access-fn))))
 406
 407 (defun %defsetf (orig-access-form num-store-vars expander)
 408   (declare (type function expander))
 409   (let (subforms
 410         subform-vars
 411         subform-exprs
 412         store-vars)
 413     (dolist (subform (cdr orig-access-form))
 414       (if (constantp subform)
 415         (push subform subforms)
 416         (let ((var (gensym)))
 417           (push var subforms)
 418           (push var subform-vars)
 419           (push subform subform-exprs))))
 420     (dotimes (i num-store-vars)
 421       (push (gensym) store-vars))
 422     (let ((r-subforms (nreverse subforms))
 423           (r-subform-vars (nreverse subform-vars))
 424           (r-subform-exprs (nreverse subform-exprs))
 425           (r-store-vars (nreverse store-vars)))
 426       (values r-subform-vars
 427               r-subform-exprs
 428               r-store-vars
 429               (funcall expander (cons r-subforms r-store-vars))
 430               `(,(car orig-access-form) ,@r-subforms)))))
 431 \f
 432 ;;;; DEFMACRO DEFINE-SETF-EXPANDER and various DEFINE-SETF-EXPANDERs
 433
 434 ;;; DEFINE-SETF-EXPANDER is a lot like DEFMACRO.
 435 (def!macro sb!xc:define-setf-expander (access-fn lambda-list &body body)
 436   #!+sb-doc
 437   "Syntax like DEFMACRO, but creates a setf expander function. The body
 438   of the definition must be a form that returns five appropriate values."
 439   (unless (symbolp access-fn)
 440     (error "~S access-function name ~S is not a symbol."
 441            'sb!xc:define-setf-expander access-fn))
 442   (with-unique-names (whole environment)
 443     (multiple-value-bind (body local-decs doc)
 444         (parse-defmacro lambda-list whole body access-fn
 445                         'sb!xc:define-setf-expander
 446                         :environment environment)
 447       `(eval-when (:compile-toplevel :load-toplevel :execute)
 448          (assign-setf-macro ',access-fn
 449                             (lambda (,whole ,environment)
 450                               ,@local-decs
 451                               ,body)
 452                             ',lambda-list
 453                             nil
 454                             ',doc)))))
 455
 456 (sb!xc:define-setf-expander getf (place prop
 457                                   &optional default
 458                                   &environment env)
 459   (declare (type sb!c::lexenv env))
 460   (multiple-value-bind (temps values stores set get)
 461       (sb!xc:get-setf-expansion place env)
 462     (let ((newval (gensym))
 463           (ptemp (gensym))
 464           (def-temp (if default (gensym))))
 465       (values `(,@temps ,ptemp ,@(if default `(,def-temp)))
 466               `(,@values ,prop ,@(if default `(,default)))
 467               `(,newval)
 468               `(let ((,(car stores) (%putf ,get ,ptemp ,newval))
 469                      ,@(cdr stores))
 470                  ,def-temp ;; prevent unused style-warning
 471                  ,set
 472                  ,newval)
 473               `(getf ,get ,ptemp ,@(if default `(,def-temp)))))))
 474
 475 (sb!xc:define-setf-expander get (symbol prop &optional default)
 476   (let ((symbol-temp (gensym))
 477         (prop-temp (gensym))
 478         (def-temp (if default (gensym)))
 479         (newval (gensym)))
 480     (values `(,symbol-temp ,prop-temp ,@(if default `(,def-temp)))
 481             `(,symbol ,prop ,@(if default `(,default)))
 482             (list newval)
 483             `(progn ,def-temp ;; prevent unused style-warning
 484                     (%put ,symbol-temp ,prop-temp ,newval))
 485             `(get ,symbol-temp ,prop-temp ,@(if default `(,def-temp))))))
 486
 487 (sb!xc:define-setf-expander gethash (key hashtable &optional default)
 488   (let ((key-temp (gensym))
 489         (hashtable-temp (gensym))
 490         (default-temp (if default (gensym)))
 491         (new-value-temp (gensym)))
 492     (values
 493      `(,key-temp ,hashtable-temp ,@(if default `(,default-temp)))
 494      `(,key ,hashtable ,@(if default `(,default)))
 495      `(,new-value-temp)
 496      `(progn ,default-temp ;; prevent unused style-warning
 497              (%puthash ,key-temp ,hashtable-temp ,new-value-temp))
 498      `(gethash ,key-temp ,hashtable-temp ,@(if default `(,default-temp))))))
 499
 500 (sb!xc:define-setf-expander logbitp (index int &environment env)
 501   (declare (type sb!c::lexenv env))
 502   (multiple-value-bind (temps vals stores store-form access-form)
 503       (sb!xc:get-setf-expansion int env)
 504     (let ((ind (gensym))
 505           (store (gensym))
 506           (stemp (first stores)))
 507       (values `(,ind ,@temps)
 508               `(,index
 509                 ,@vals)
 510               (list store)
 511               `(let ((,stemp
 512                       (dpb (if ,store 1 0) (byte 1 ,ind) ,access-form))
 513                      ,@(cdr stores))
 514                  ,store-form
 515                  ,store)
 516               `(logbitp ,ind ,access-form)))))
 517
 518 ;;; CMU CL had a comment here that:
 519 ;;;   Evil hack invented by the gnomes of Vassar Street (though not as evil as
 520 ;;;   it used to be.)  The function arg must be constant, and is converted to
 521 ;;;   an APPLY of the SETF function, which ought to exist.
 522 ;;;
 523 ;;; It may not be clear (wasn't to me..) that this is a standard thing, but See
 524 ;;; "5.1.2.5 APPLY Forms as Places" in the ANSI spec. I haven't actually
 525 ;;; verified that this code has any correspondence to that code, but at least
 526 ;;; ANSI has some place for SETF APPLY. -- WHN 19990604
 527 (sb!xc:define-setf-expander apply (functionoid &rest args)
 528   (unless (and (listp functionoid)
 529                (= (length functionoid) 2)
 530                (eq (first functionoid) 'function)
 531                (symbolp (second functionoid)))
 532     (error "SETF of APPLY is only defined for function args like #'SYMBOL."))
 533   (let ((function (second functionoid))
 534         (new-var (gensym))
 535         (vars (make-gensym-list (length args))))
 536     (values vars args (list new-var)
 537             `(apply #'(setf ,function) ,new-var ,@vars)
 538             `(apply #',function ,@vars))))
 539
 540 ;;; Special-case a BYTE bytespec so that the compiler can recognize it.
 541 (sb!xc:define-setf-expander ldb (bytespec place &environment env)
 542   #!+sb-doc
 543   "The first argument is a byte specifier. The second is any place form
 544   acceptable to SETF. Replace the specified byte of the number in this
 545   place with bits from the low-order end of the new value."
 546   (declare (type sb!c::lexenv env))
 547   (multiple-value-bind (dummies vals newval setter getter)
 548       (sb!xc:get-setf-expansion place env)
 549     (if (and (consp bytespec) (eq (car bytespec) 'byte))
 550         (let ((n-size (gensym))
 551               (n-pos (gensym))
 552               (n-new (gensym)))
 553           (values (list* n-size n-pos dummies)
 554                   (list* (second bytespec) (third bytespec) vals)
 555                   (list n-new)
 556                   `(let ((,(car newval) (dpb ,n-new (byte ,n-size ,n-pos)
 557                                              ,getter))
 558                          ,@(cdr newval))
 559                      ,setter
 560                      ,n-new)
 561                   `(ldb (byte ,n-size ,n-pos) ,getter)))
 562         (let ((btemp (gensym))
 563               (gnuval (gensym)))
 564           (values (cons btemp dummies)
 565                   (cons bytespec vals)
 566                   (list gnuval)
 567                   `(let ((,(car newval) (dpb ,gnuval ,btemp ,getter)))
 568                      ,setter
 569                      ,gnuval)
 570                   `(ldb ,btemp ,getter))))))
 571
 572 (sb!xc:define-setf-expander mask-field (bytespec place &environment env)
 573   #!+sb-doc
 574   "The first argument is a byte specifier. The second is any place form
 575   acceptable to SETF. Replaces the specified byte of the number in this place
 576   with bits from the corresponding position in the new value."
 577   (declare (type sb!c::lexenv env))
 578   (multiple-value-bind (dummies vals newval setter getter)
 579       (sb!xc:get-setf-expansion place env)
 580     (let ((btemp (gensym))
 581           (gnuval (gensym)))
 582       (values (cons btemp dummies)
 583               (cons bytespec vals)
 584               (list gnuval)
 585               `(let ((,(car newval) (deposit-field ,gnuval ,btemp ,getter))
 586                      ,@(cdr newval))
 587                  ,setter
 588                  ,gnuval)
 589               `(mask-field ,btemp ,getter)))))
 590
 591 (defun setf-expand-the (the type place env)
 592   (declare (type sb!c::lexenv env))
 593   (multiple-value-bind (temps subforms store-vars setter getter)
 594       (sb!xc:get-setf-expansion place env)
 595     (values temps subforms store-vars
 596             `(multiple-value-bind ,store-vars
 597                  (,the ,type (values ,@store-vars))
 598                ,setter)
 599             `(,the ,type ,getter))))
 600
 601 (sb!xc:define-setf-expander the (type place &environment env)
 602   (setf-expand-the 'the type place env))
 603
 604 (sb!xc:define-setf-expander truly-the (type place &environment env)
 605   (setf-expand-the 'truly-the type place env))