1.0.7.5: allow WITH-INTERRUPTS inside "system locked" sections
[sbcl.git] / 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                (sb!xc:macroexpand-1 form environment)
42              (if expanded
43                  (sb!xc:get-setf-expansion expansion environment)
44                  (let ((new-var (gensym)))
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))
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 ;;; GET-SETF-METHOD existed in pre-ANSI Common Lisp, and various code inherited
74 ;;; from CMU CL uses it repeatedly, so rather than rewrite a lot of code to not
75 ;;; use it, we just define it in terms of ANSI's GET-SETF-EXPANSION (or
76 ;;; actually, the cross-compiler version of that, i.e.
77 ;;; SB!XC:GET-SETF-EXPANSION).
78 (declaim (ftype (function (t &optional (or null sb!c::lexenv))) get-setf-method))
79 (defun get-setf-method (form &optional environment)
80   #!+sb-doc
81   "This is a specialized-for-one-value version of GET-SETF-EXPANSION (and
82 a relic from pre-ANSI Common Lisp). Portable ANSI code should use
83 GET-SETF-EXPANSION directly."
84   (multiple-value-bind (temps value-forms store-vars store-form access-form)
85       (sb!xc:get-setf-expansion form environment)
86     (when (cdr store-vars)
87       (error "GET-SETF-METHOD used for a form with multiple store ~
88               variables:~%  ~S"
89              form))
90     (values temps value-forms store-vars store-form access-form)))
91
92 ;;; If a macro, expand one level and try again. If not, go for the
93 ;;; SETF function.
94 (declaim (ftype (function (t (or null sb!c::lexenv)))
95                 expand-or-get-setf-inverse))
96 (defun expand-or-get-setf-inverse (form environment)
97   (multiple-value-bind (expansion expanded)
98       (sb!xc:macroexpand-1 form environment)
99     (if expanded
100         (sb!xc:get-setf-expansion expansion environment)
101         (get-setf-method-inverse form
102                                  `(funcall #'(setf ,(car form)))
103                                  t))))
104
105 (defun get-setf-method-inverse (form inverse setf-fun)
106   (let ((new-var (gensym))
107         (vars nil)
108         (vals nil))
109     (dolist (x (cdr form))
110       (push (gensym) vars)
111       (push x vals))
112     (setq vals (nreverse vals))
113     (values vars vals (list new-var)
114             (if setf-fun
115                 `(,@inverse ,new-var ,@vars)
116                 `(,@inverse ,@vars ,new-var))
117             `(,(car form) ,@vars))))
118 \f
119 ;;;; SETF itself
120
121 ;;; Except for atoms, we always call GET-SETF-EXPANSION, since it has
122 ;;; some non-trivial semantics. But when there is a setf inverse, and
123 ;;; G-S-E uses it, then we return a call to the inverse, rather than
124 ;;; returning a hairy LET form. This is probably important mainly as a
125 ;;; convenience in allowing the use of SETF inverses without the full
126 ;;; 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 (let*-bindings mv-bindings setters getters)
169     (dolist (arg (butlast args))
170       (multiple-value-bind (temps subforms store-vars setter getter)
171           (sb!xc:get-setf-expansion arg env)
172         (mapc (lambda (tmp form)
173                 (push `(,tmp ,form) let*-bindings))
174               temps
175               subforms)
176         (push store-vars mv-bindings)
177         (push setter setters)
178         (push getter getters)))
179     ;; Handle the last arg specially here. The getter is just the last
180     ;; arg itself.
181     (push (car (last args)) getters)
182
183     ;; Reverse the collected lists so last bit looks nicer.
184     (setf let*-bindings (nreverse let*-bindings)
185           mv-bindings (nreverse mv-bindings)
186           setters (nreverse setters)
187           getters (nreverse getters))
188
189     (labels ((thunk (mv-bindings getters)
190                (if mv-bindings
191                    `((multiple-value-bind
192                            ,(car mv-bindings)
193                          ,(car getters)
194                        ,@(thunk (cdr mv-bindings) (cdr getters))))
195                    `(,@setters))))
196       `(let ,let*-bindings
197         (multiple-value-bind ,(car mv-bindings)
198             ,(car getters)
199           ,@(thunk mv-bindings (cdr getters))
200           (values ,@(car mv-bindings)))))))
201
202 (defmacro-mundanely push (obj place &environment env)
203   #!+sb-doc
204   "Takes an object and a location holding a list. Conses the object onto
205   the list, returning the modified list. OBJ is evaluated before PLACE."
206   (multiple-value-bind (dummies vals newval setter getter)
207       (get-setf-method place env)
208     (let ((g (gensym)))
209       `(let* ((,g ,obj)
210               ,@(mapcar #'list dummies vals)
211               (,(car newval) (cons ,g ,getter)))
212          ,setter))))
213
214 (defmacro-mundanely pushnew (obj place &rest keys &environment env)
215   #!+sb-doc
216   "Takes an object and a location holding a list. If the object is
217   already in the list, does nothing; otherwise, conses the object onto
218   the list. Returns the modified list. If there is a :TEST keyword, this
219   is used for the comparison."
220   (multiple-value-bind (dummies vals newval setter getter)
221       (get-setf-method place env)
222     (let ((g (gensym)))
223       `(let* ((,g ,obj)
224               ,@(mapcar #'list dummies vals)
225               (,(car newval) (adjoin ,g ,getter ,@keys)))
226          ,setter))))
227
228 (defmacro-mundanely pop (place &environment env)
229   #!+sb-doc
230   "The argument is a location holding a list. Pops one item off the front
231   of the list and returns it."
232   (multiple-value-bind (dummies vals newval setter getter)
233       (get-setf-method place env)
234     (do* ((d dummies (cdr d))
235           (v vals (cdr v))
236           (let-list nil))
237          ((null d)
238           (push (list (car newval) getter) let-list)
239           `(let* ,(nreverse let-list)
240              (prog1 (car ,(car newval))
241                (setq ,(car newval) (cdr ,(car newval)))
242                ,setter)))
243       (push (list (car d) (car v)) let-list))))
244
245 (defmacro-mundanely remf (place indicator &environment env)
246   #!+sb-doc
247   "Place may be any place expression acceptable to SETF, and is expected
248   to hold a property list or (). This list is destructively altered to
249   remove the property specified by the indicator. Returns T if such a
250   property was present, NIL if not."
251   (multiple-value-bind (dummies vals newval setter getter)
252       (get-setf-method place env)
253     (do* ((d dummies (cdr d))
254           (v vals (cdr v))
255           (let-list nil)
256           (ind-temp (gensym))
257           (local1 (gensym))
258           (local2 (gensym)))
259          ((null d)
260           ;; See ANSI 5.1.3 for why we do out-of-order evaluation
261           (push (list ind-temp indicator) let-list)
262           (push (list (car newval) getter) let-list)
263           `(let* ,(nreverse let-list)
264              (do ((,local1 ,(car newval) (cddr ,local1))
265                   (,local2 nil ,local1))
266                  ((atom ,local1) nil)
267                (cond ((atom (cdr ,local1))
268                       (error "Odd-length property list in REMF."))
269                      ((eq (car ,local1) ,ind-temp)
270                       (cond (,local2
271                              (rplacd (cdr ,local2) (cddr ,local1))
272                              (return t))
273                             (t (setq ,(car newval) (cddr ,(car newval)))
274                                ,setter
275                                (return t))))))))
276       (push (list (car d) (car v)) let-list))))
277
278 ;;; we can't use DEFINE-MODIFY-MACRO because of ANSI 5.1.3
279 (defmacro-mundanely incf (place &optional (delta 1) &environment env)
280   #!+sb-doc
281   "The first argument is some location holding a number. This number is
282   incremented by the second argument, DELTA, which defaults to 1."
283   (multiple-value-bind (dummies vals newval setter getter)
284       (get-setf-method place env)
285     (let ((d (gensym)))
286       `(let* (,@(mapcar #'list dummies vals)
287               (,d ,delta)
288               (,(car newval) (+ ,getter ,d)))
289          ,setter))))
290
291 (defmacro-mundanely decf (place &optional (delta 1) &environment env)
292   #!+sb-doc
293   "The first argument is some location holding a number. This number is
294   decremented by the second argument, DELTA, which defaults to 1."
295   (multiple-value-bind (dummies vals newval setter getter)
296       (get-setf-method place env)
297     (let ((d (gensym)))
298       `(let* (,@(mapcar #'list dummies vals)
299               (,d ,delta)
300               (,(car newval) (- ,getter ,d)))
301          ,setter))))
302 \f
303 ;;;; DEFINE-MODIFY-MACRO stuff
304
305 (def!macro sb!xc:define-modify-macro (name lambda-list function &optional doc-string)
306   #!+sb-doc
307   "Creates a new read-modify-write macro like PUSH or INCF."
308   (let ((other-args nil)
309         (rest-arg nil)
310         (env (gensym))
311         (reference (gensym)))
312     ;; Parse out the variable names and &REST arg from the lambda list.
313     (do ((ll lambda-list (cdr ll))
314          (arg nil))
315         ((null ll))
316       (setq arg (car ll))
317       (cond ((eq arg '&optional))
318             ((eq arg '&rest)
319              (if (symbolp (cadr ll))
320                (setq rest-arg (cadr ll))
321                (error "Non-symbol &REST argument in definition of ~S." name))
322              (if (null (cddr ll))
323                (return nil)
324                (error "Illegal stuff after &REST argument.")))
325             ((memq arg '(&key &allow-other-keys &aux))
326              (error "~S not allowed in DEFINE-MODIFY-MACRO lambda list." arg))
327             ((symbolp arg)
328              (push arg other-args))
329             ((and (listp arg) (symbolp (car arg)))
330              (push (car arg) other-args))
331             (t (error "Illegal stuff in lambda list."))))
332     (setq other-args (nreverse other-args))
333     `(#-sb-xc-host sb!xc:defmacro
334       #+sb-xc-host defmacro-mundanely
335          ,name (,reference ,@lambda-list &environment ,env)
336        ,doc-string
337        (multiple-value-bind (dummies vals newval setter getter)
338            (get-setf-method ,reference ,env)
339          (do ((d dummies (cdr d))
340               (v vals (cdr v))
341               (let-list nil (cons (list (car d) (car v)) let-list)))
342              ((null d)
343               (push (list (car newval)
344                           ,(if rest-arg
345                              `(list* ',function getter ,@other-args ,rest-arg)
346                              `(list ',function getter ,@other-args)))
347                     let-list)
348               `(let* ,(nreverse let-list)
349                  ,setter)))))))
350 \f
351 ;;;; DEFSETF
352
353 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
354   ;;; Assign SETF macro information for NAME, making all appropriate checks.
355   (defun assign-setf-macro (name expander inverse doc)
356     (with-single-package-locked-error
357         (:symbol name "defining a setf-expander for ~A"))
358     (cond ((gethash name sb!c:*setf-assumed-fboundp*)
359            (warn
360             "defining setf macro for ~S when ~S was previously ~
361              treated as a function"
362             name
363             `(setf ,name)))
364           ((not (fboundp `(setf ,name)))
365            ;; All is well, we don't need any warnings.
366            (values))
367           ((not (eq (symbol-package name) (symbol-package 'aref)))
368            (style-warn "defining setf macro for ~S when ~S is fbound"
369                        name `(setf ,name))))
370     (remhash name sb!c:*setf-assumed-fboundp*)
371     ;; FIXME: It's probably possible to join these checks into one form which
372     ;; is appropriate both on the cross-compilation host and on the target.
373     (when (or inverse (info :setf :inverse name))
374       (setf (info :setf :inverse name) inverse))
375     (when (or expander (info :setf :expander name))
376       (setf (info :setf :expander name) expander))
377     (when doc
378       (setf (fdocumentation name 'setf) doc))
379     name))
380
381 (def!macro sb!xc:defsetf (access-fn &rest rest)
382   #!+sb-doc
383   "Associates a SETF update function or macro with the specified access
384   function or macro. The format is complex. See the manual for details."
385   (cond ((not (listp (car rest)))
386          `(eval-when (:load-toplevel :compile-toplevel :execute)
387             (assign-setf-macro ',access-fn
388                                nil
389                                ',(car rest)
390                                 ,(when (and (car rest) (stringp (cadr rest)))
391                                    `',(cadr rest)))))
392         ((and (cdr rest) (listp (cadr rest)))
393          (destructuring-bind
394              (lambda-list (&rest store-variables) &body body)
395              rest
396            (let ((whole-var (gensym "WHOLE-"))
397                  (access-form-var (gensym "ACCESS-FORM-"))
398                  (env-var (gensym "ENVIRONMENT-")))
399              (multiple-value-bind (body local-decs doc)
400                  (parse-defmacro `(,lambda-list ,@store-variables)
401                                  whole-var body access-fn 'defsetf
402                                  :environment env-var
403                                  :anonymousp t)
404                `(eval-when (:compile-toplevel :load-toplevel :execute)
405                   (assign-setf-macro
406                    ',access-fn
407                    (lambda (,access-form-var ,env-var)
408                      ,@local-decs
409                      (%defsetf ,access-form-var ,(length store-variables)
410                                (lambda (,whole-var)
411                                  ,body)))
412                    nil
413                    ',doc))))))
414         (t
415          (error "ill-formed DEFSETF for ~S" access-fn))))
416
417 (defun %defsetf (orig-access-form num-store-vars expander)
418   (declare (type function expander))
419   (let (subforms
420         subform-vars
421         subform-exprs
422         store-vars)
423     (dolist (subform (cdr orig-access-form))
424       (if (constantp subform)
425         (push subform subforms)
426         (let ((var (gensym)))
427           (push var subforms)
428           (push var subform-vars)
429           (push subform subform-exprs))))
430     (dotimes (i num-store-vars)
431       (push (gensym) store-vars))
432     (let ((r-subforms (nreverse subforms))
433           (r-subform-vars (nreverse subform-vars))
434           (r-subform-exprs (nreverse subform-exprs))
435           (r-store-vars (nreverse store-vars)))
436       (values r-subform-vars
437               r-subform-exprs
438               r-store-vars
439               (funcall expander (cons r-subforms r-store-vars))
440               `(,(car orig-access-form) ,@r-subforms)))))
441 \f
442 ;;;; DEFMACRO DEFINE-SETF-EXPANDER and various DEFINE-SETF-EXPANDERs
443
444 ;;; DEFINE-SETF-EXPANDER is a lot like DEFMACRO.
445 (def!macro sb!xc:define-setf-expander (access-fn lambda-list &body body)
446   #!+sb-doc
447   "Syntax like DEFMACRO, but creates a setf expander function. The body
448   of the definition must be a form that returns five appropriate values."
449   (unless (symbolp access-fn)
450     (error "~S access-function name ~S is not a symbol."
451            'sb!xc:define-setf-expander access-fn))
452   (with-unique-names (whole environment)
453     (multiple-value-bind (body local-decs doc)
454         (parse-defmacro lambda-list whole body access-fn
455                         'sb!xc:define-setf-expander
456                         :environment environment)
457       `(eval-when (:compile-toplevel :load-toplevel :execute)
458          (assign-setf-macro ',access-fn
459                             (lambda (,whole ,environment)
460                               ,@local-decs
461                               ,body)
462                             nil
463                             ',doc)))))
464
465 (sb!xc:define-setf-expander getf (place prop
466                                   &optional default
467                                   &environment env)
468   (declare (type sb!c::lexenv env))
469   (multiple-value-bind (temps values stores set get)
470       (get-setf-method place env)
471     (let ((newval (gensym))
472           (ptemp (gensym))
473           (def-temp (if default (gensym))))
474       (values `(,@temps ,ptemp ,@(if default `(,def-temp)))
475               `(,@values ,prop ,@(if default `(,default)))
476               `(,newval)
477               `(let ((,(car stores) (%putf ,get ,ptemp ,newval)))
478                  ,set
479                  ,newval)
480               `(getf ,get ,ptemp ,@(if default `(,def-temp)))))))
481
482 (sb!xc:define-setf-expander get (symbol prop &optional default)
483   (let ((symbol-temp (gensym))
484         (prop-temp (gensym))
485         (def-temp (gensym))
486         (newval (gensym)))
487     (values `(,symbol-temp ,prop-temp ,@(if default `(,def-temp)))
488             `(,symbol ,prop ,@(if default `(,default)))
489             (list newval)
490             `(%put ,symbol-temp ,prop-temp ,newval)
491             `(get ,symbol-temp ,prop-temp ,@(if default `(,def-temp))))))
492
493 (sb!xc:define-setf-expander gethash (key hashtable &optional default)
494   (let ((key-temp (gensym))
495         (hashtable-temp (gensym))
496         (default-temp (gensym))
497         (new-value-temp (gensym)))
498     (values
499      `(,key-temp ,hashtable-temp ,@(if default `(,default-temp)))
500      `(,key ,hashtable ,@(if default `(,default)))
501      `(,new-value-temp)
502      `(%puthash ,key-temp ,hashtable-temp ,new-value-temp)
503      `(gethash ,key-temp ,hashtable-temp ,@(if default `(,default-temp))))))
504
505 (sb!xc:define-setf-expander logbitp (index int &environment env)
506   (declare (type sb!c::lexenv env))
507   (multiple-value-bind (temps vals stores store-form access-form)
508       (get-setf-method int env)
509     (let ((ind (gensym))
510           (store (gensym))
511           (stemp (first stores)))
512       (values `(,ind ,@temps)
513               `(,index
514                 ,@vals)
515               (list store)
516               `(let ((,stemp
517                       (dpb (if ,store 1 0) (byte 1 ,ind) ,access-form)))
518                  ,store-form
519                  ,store)
520               `(logbitp ,ind ,access-form)))))
521
522 ;;; CMU CL had a comment here that:
523 ;;;   Evil hack invented by the gnomes of Vassar Street (though not as evil as
524 ;;;   it used to be.)  The function arg must be constant, and is converted to
525 ;;;   an APPLY of the SETF function, which ought to exist.
526 ;;;
527 ;;; It may not be clear (wasn't to me..) that this is a standard thing, but See
528 ;;; "5.1.2.5 APPLY Forms as Places" in the ANSI spec. I haven't actually
529 ;;; verified that this code has any correspondence to that code, but at least
530 ;;; ANSI has some place for SETF APPLY. -- WHN 19990604
531 (sb!xc:define-setf-expander apply (functionoid &rest args)
532   (unless (and (listp functionoid)
533                (= (length functionoid) 2)
534                (eq (first functionoid) 'function)
535                (symbolp (second functionoid)))
536     (error "SETF of APPLY is only defined for function args like #'SYMBOL."))
537   (let ((function (second functionoid))
538         (new-var (gensym))
539         (vars (make-gensym-list (length args))))
540     (values vars args (list new-var)
541             `(apply #'(setf ,function) ,new-var ,@vars)
542             `(apply #',function ,@vars))))
543
544 ;;; Special-case a BYTE bytespec so that the compiler can recognize it.
545 (sb!xc:define-setf-expander ldb (bytespec place &environment env)
546   #!+sb-doc
547   "The first argument is a byte specifier. The second is any place form
548   acceptable to SETF. Replace the specified byte of the number in this
549   place with bits from the low-order end of the new value."
550   (declare (type sb!c::lexenv env))
551   (multiple-value-bind (dummies vals newval setter getter)
552       (get-setf-method place env)
553     (if (and (consp bytespec) (eq (car bytespec) 'byte))
554         (let ((n-size (gensym))
555               (n-pos (gensym))
556               (n-new (gensym)))
557           (values (list* n-size n-pos dummies)
558                   (list* (second bytespec) (third bytespec) vals)
559                   (list n-new)
560                   `(let ((,(car newval) (dpb ,n-new (byte ,n-size ,n-pos)
561                                              ,getter)))
562                      ,setter
563                      ,n-new)
564                   `(ldb (byte ,n-size ,n-pos) ,getter)))
565         (let ((btemp (gensym))
566               (gnuval (gensym)))
567           (values (cons btemp dummies)
568                   (cons bytespec vals)
569                   (list gnuval)
570                   `(let ((,(car newval) (dpb ,gnuval ,btemp ,getter)))
571                      ,setter
572                      ,gnuval)
573                   `(ldb ,btemp ,getter))))))
574
575 (sb!xc:define-setf-expander mask-field (bytespec place &environment env)
576   #!+sb-doc
577   "The first argument is a byte specifier. The second is any place form
578   acceptable to SETF. Replaces the specified byte of the number in this place
579   with bits from the corresponding position in the new value."
580   (declare (type sb!c::lexenv env))
581   (multiple-value-bind (dummies vals newval setter getter)
582       (get-setf-method place env)
583     (let ((btemp (gensym))
584           (gnuval (gensym)))
585       (values (cons btemp dummies)
586               (cons bytespec vals)
587               (list gnuval)
588               `(let ((,(car newval) (deposit-field ,gnuval ,btemp ,getter)))
589                  ,setter
590                  ,gnuval)
591               `(mask-field ,btemp ,getter)))))
592
593 (sb!xc:define-setf-expander the (type place &environment env)
594   (declare (type sb!c::lexenv env))
595   (multiple-value-bind (temps subforms store-vars setter getter)
596       (sb!xc:get-setf-expansion place env)
597     (values temps subforms store-vars
598             `(multiple-value-bind ,store-vars
599                  (the ,type (values ,@store-vars))
600                ,setter)
601             `(the ,type ,getter))))