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