Put standard define-setf-macros with the rest of defsetfs.
[sbcl.git] / src / code / setf.lisp
blob9b7de22d56d1d9bdc483658af546717b1b2579c9
1 ;;;; SETF and friends
2 ;;;;
3 ;;;; Note: The expansions for SETF and friends sometimes create
4 ;;;; needless LET-bindings of argument values. The compiler will
5 ;;;; remove most of these spurious bindings, so SETF doesn't worry too
6 ;;;; much about creating them.
8 ;;;; This software is part of the SBCL system. See the README file for
9 ;;;; more information.
10 ;;;;
11 ;;;; This software is derived from the CMU CL system, which was
12 ;;;; written at Carnegie Mellon University and released into the
13 ;;;; public domain. The software is in the public domain and is
14 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
15 ;;;; files for more information.
17 (in-package "SB!IMPL")
19 ;;; Return T if FUN names a DEFSTRUCT slot accessor that we should
20 ;;; transform from SETF into %INSTANCE-SET directly - bypassing
21 ;;; #'(SETF MYSLOT) - which requires that the slot be read/writable.
22 ;;; A local function named (SETF MYSLOT) inhibits the transform,
23 ;;; though technically need not, as it is unspecified how SETF
24 ;;; of a structure slot expands. It is likewise unportable to
25 ;;; expect that a NOTINLINE does anything, but we'll check anyway.
26 (defun transformable-struct-setf-p (form env)
27 (when (singleton-p (cdr form))
28 (let* ((fun (car form))
29 (slot-info (structure-instance-accessor-p fun)))
30 (when (and slot-info (not (dsd-read-only (cdr slot-info))))
31 (dx-let ((setter `(setf ,fun)))
32 (when (and (not (sb!c::fun-locally-defined-p setter env))
33 (not (sb!c::fun-lexically-notinline-p setter env)))
34 slot-info)))))) ; caller needs the (DD . DSD) pair
36 ;;; The inverse for a generalized-variable reference function is stored in
37 ;;; one of two ways:
38 ;;;
39 ;;; A SETF inverse property corresponds to the short form of DEFSETF. It is
40 ;;; the name of a function takes the same args as the reference form, plus a
41 ;;; new-value arg at the end.
42 ;;;
43 ;;; A SETF method expander is created by the long form of DEFSETF or
44 ;;; by DEFINE-SETF-EXPANDER. It is a function that is called on the reference
45 ;;; form and that produces five values: a list of temporary variables, a list
46 ;;; of value forms, a list of the single store-value form, a storing function,
47 ;;; and an accessing function.
48 (declaim (ftype (function (t &optional lexenv-designator))
49 sb!xc:get-setf-expansion))
50 (defun sb!xc:get-setf-expansion (form &optional environment
51 ;; Assume we'll need one store temp.
52 ;; That's the expected thing.
53 &aux (store (sb!xc:gensym "NEW")))
54 #!+sb-doc
55 "Return five values needed by the SETF machinery: a list of temporary
56 variables, a list of values with which to fill them, a list of temporaries
57 for the new values, the setting function, and the accessing function."
58 (if (symbolp form)
59 (multiple-value-bind (expansion expanded)
60 (sb!xc:macroexpand-1 form environment)
61 (if expanded
62 (sb!xc:get-setf-expansion expansion environment)
63 (values nil nil (list store) `(setq ,form ,store) form)))
64 (let ((fun (car form)))
65 (flet ((expand (call arg-maker)
66 ;; Produce the expansion of a SETF form that calls either
67 ;; #'(SETF name) or an inverse given by short form DEFSETF.
68 (multiple-value-bind (temp-vars temp-vals args)
69 (collect-setf-temps (cdr form) environment nil)
70 (values temp-vars temp-vals (list store)
71 `(,.call ,@(funcall arg-maker store args))
72 `(,fun ,@args)))))
73 ;; Local functions inhibit global SETF methods.
74 (unless (sb!c::fun-locally-defined-p fun environment)
75 (acond ((info :setf :inverse fun)
76 (return-from sb!xc:get-setf-expansion
77 (expand `(,it) (lambda (new args) `(,@args ,new)))))
78 ((info :setf :expander fun)
79 (return-from sb!xc:get-setf-expansion
80 (if (consp it)
81 (make-setf-quintuple form environment
82 (car it) (cdr it))
83 (funcall it form environment))))
84 ((transformable-struct-setf-p form environment)
85 (let ((instance (make-symbol "OBJ")))
86 (return-from sb!xc:get-setf-expansion
87 (values (list instance)
88 (list (cadr form))
89 (list store)
90 (slot-access-transform
91 :setf (list instance store) it)
92 (slot-access-transform
93 :read (list instance) it)))))))
94 ;; When NAME is a macro, retry from the top.
95 ;; Otherwise default to the function named `(SETF ,name).
96 (multiple-value-bind (expansion expanded)
97 (%macroexpand-1 form environment)
98 (if expanded
99 (sb!xc:get-setf-expansion expansion environment)
100 (expand `(funcall #'(setf ,fun)) #'cons)))))))
102 ;; Expand PLACE until it is a form that SETF might know something about.
103 ;; Macros are expanded only when no SETF expander (or inverse) exists.
104 ;; Symbol-macros are always expanded because there are no SETF expanders
105 ;; for them. This is useful mainly when a symbol-macro or ordinary macro
106 ;; expands to a "mundane" lexical or special variable.
107 (defun macroexpand-for-setf (place environment)
108 (loop
109 (when (and (listp place)
110 (let ((op (car place)))
111 (or (info :setf :expander op) (info :setf :inverse op))))
112 (return place))
113 (multiple-value-bind (expansion macro-p) (%macroexpand-1 place environment)
114 (if macro-p
115 (setq place expansion) ; iterate
116 (return place)))))
118 ;;;; SETF itself
120 ;; Code shared by SETF, PSETF, SHIFTF attempting to minimize the expansion.
121 ;; This has significant speed+space benefit to a non-preprocessing interpreter,
122 ;; and to some degree a preprocessing interpreter.
123 (labels ((gen-let* (bindings body-forms)
124 (cond ((not bindings) body-forms)
126 (when (and (singleton-p body-forms)
127 (listp (car body-forms))
128 (eq (caar body-forms) 'let*))
129 (let ((nested (cdar body-forms))) ; extract the nested LET*
130 (setq bindings (append bindings (car nested))
131 body-forms (cdr nested))))
132 `((let* ,bindings ,@body-forms)))))
133 (gen-mv-bind (stores values body-forms)
134 (if (singleton-p stores)
135 (gen-let* `((,(car stores) ,values)) body-forms)
136 `((multiple-value-bind ,stores ,values ,@body-forms))))
137 (forms-list (form)
138 (if (and (consp form) (eq (car form) 'progn))
139 (cdr form)
140 (list form)))
141 ;; Instead of emitting (PROGN (VALUES (SETQ ...) (SETQ ...)) NIL)
142 ;; the SETQs can be lifted into the PROGN. This is unimportant
143 ;; for compiled code, but it helps the interpreter not needlessly
144 ;; collect arguments to call VALUES; and it's more human-readable.
145 (de-values-ify (forms)
146 (mapcan (lambda (form)
147 (if (and (listp form) (eq (car form) 'values))
148 (copy-list (cdr form))
149 (list form)))
150 forms)))
152 (defmacro-mundanely setf (&whole form &rest args &environment env)
153 #!+sb-doc
154 "Takes pairs of arguments like SETQ. The first is a place and the second
155 is the value that is supposed to go into that place. Returns the last
156 value. The place argument may be any of the access forms for which SETF
157 knows a corresponding setting form."
158 (unless args
159 (return-from setf nil))
160 (destructuring-bind (place value-form . more) args
161 (when more
162 (return-from setf `(progn ,@(sb!c::explode-setq form 'error))))
163 (when (symbolp (setq place (macroexpand-for-setf place env)))
164 (return-from setf `(setq ,place ,value-form)))
166 (let ((fun (car place)))
167 (when (and (symbolp fun)
168 ;; Local definition of FUN precludes global knowledge.
169 (not (sb!c::fun-locally-defined-p fun env)))
170 (awhen (info :setf :inverse fun)
171 (return-from setf `(,it ,@(cdr place) ,value-form)))
172 (awhen (transformable-struct-setf-p place env)
173 (return-from setf
174 (slot-access-transform
175 :setf (list (cadr place) value-form) it)))))
177 (multiple-value-bind (temps vals newval setter)
178 (sb!xc:get-setf-expansion place env)
179 (car (gen-let* (mapcar #'list temps vals)
180 (gen-mv-bind newval value-form (forms-list setter)))))))
182 ;; various SETF-related macros
184 (defmacro-mundanely shiftf (&whole form &rest args &environment env)
185 #!+sb-doc
186 "One or more SETF-style place expressions, followed by a single
187 value expression. Evaluates all of the expressions in turn, then
188 assigns the value of each expression to the place on its left,
189 returning the value of the leftmost."
190 (when (< (length args) 2)
191 (error "~S called with too few arguments: ~S" 'shiftf form))
192 (collect ((let*-bindings) (mv-bindings) (setters) (getters))
193 (dolist (arg (butlast args))
194 (multiple-value-bind (temps subforms store-vars setter getter)
195 (sb!xc:get-setf-expansion arg env)
196 (let*-bindings (mapcar #'list temps subforms))
197 (mv-bindings store-vars)
198 (setters setter)
199 (getters getter)))
200 ;; Handle the last arg specially here. The getter is just the last
201 ;; arg itself.
202 (getters (car (last args)))
203 (labels ((thunk (mv-bindings getters setters)
204 (if mv-bindings
205 (gen-mv-bind (car mv-bindings) (car getters)
206 (thunk (cdr mv-bindings) (cdr getters) setters))
207 setters)))
208 (let ((outputs (loop for i below (length (car (mv-bindings)))
209 collect (sb!xc:gensym "OUT"))))
210 (car (gen-let* (reduce #'nconc (let*-bindings))
211 (gen-mv-bind outputs (car (getters))
212 (thunk (mv-bindings) (cdr (getters))
213 `(,@(de-values-ify (setters))
214 (values ,@outputs))))))))))
216 (labels
217 ((expand (args env operator single-op)
218 (cond ((singleton-p (cdr args)) ; commonest case probably
219 (return-from expand `(progn (,single-op ,@args) nil)))
220 ((not args)
221 (return-from expand nil)))
222 (collect ((let*-bindings) (mv-bindings) (setters))
223 (do ((a args (cddr a)))
224 ((endp a))
225 (when (endp (cdr a))
226 (error "Odd number of args to ~S." operator))
227 (let ((place (car a))
228 (value-form (cadr a)))
229 (when (and (not (symbolp place)) (eq operator 'psetq))
230 (error 'simple-program-error
231 :format-control "Place ~S in PSETQ is not a SYMBOL"
232 :format-arguments (list place)))
233 (multiple-value-bind (temps vals stores setter)
234 (sb!xc:get-setf-expansion place env)
235 (let*-bindings (mapcar #'list temps vals))
236 (mv-bindings (cons stores value-form))
237 (setters setter))))
238 (car (build (let*-bindings) (mv-bindings)
239 (de-values-ify (setters))))))
240 (build (let*-bindings mv-bindings setters)
241 (if let*-bindings
242 (gen-let* (car let*-bindings)
243 (gen-mv-bind (caar mv-bindings) (cdar mv-bindings)
244 (build (cdr let*-bindings) (cdr mv-bindings)
245 setters)))
246 `(,@setters nil))))
248 (defmacro-mundanely psetf (&rest pairs &environment env)
249 #!+sb-doc
250 "This is to SETF as PSETQ is to SETQ. Args are alternating place
251 expressions and values to go into those places. All of the subforms and
252 values are determined, left to right, and only then are the locations
253 updated. Returns NIL."
254 (expand pairs env 'psetf 'setf))
256 (defmacro-mundanely psetq (&rest pairs &environment env)
257 #!+sb-doc
258 "PSETQ {var value}*
259 Set the variables to the values, like SETQ, except that assignments
260 happen in parallel, i.e. no assignments take place until all the
261 forms have been evaluated."
262 (expand pairs env 'psetq 'setq))))
264 ;;; FIXME: the following claim could not possibly be true, could it?
265 ;;; FIXME: Compiling this definition of ROTATEF apparently blows away the
266 ;;; definition in the cross-compiler itself, so that after that, any
267 ;;; ROTATEF operations can no longer be compiled, because
268 ;;; GET-SETF-EXPANSION is called instead of SB!XC:GET-SETF-EXPANSION.
269 (defmacro-mundanely rotatef (&rest args &environment env)
270 #!+sb-doc
271 "Takes any number of SETF-style place expressions. Evaluates all of the
272 expressions in turn, then assigns to each place the value of the form to
273 its right. The rightmost form gets the value of the leftmost.
274 Returns NIL."
275 (when args
276 (collect ((let*-bindings) (mv-bindings) (setters) (getters))
277 (dolist (arg args)
278 (multiple-value-bind (temps subforms store-vars setter getter)
279 (sb!xc:get-setf-expansion arg env)
280 (let*-bindings (mapcar #'list temps subforms))
281 (mv-bindings store-vars)
282 (setters setter)
283 (getters getter)))
284 (setters nil)
285 (getters (car (getters)))
286 (labels ((thunk (mv-bindings getters)
287 (if mv-bindings
288 `((multiple-value-bind ,(car mv-bindings) ,(car getters)
289 ,@(thunk (cdr mv-bindings) (cdr getters))))
290 (setters))))
291 `(let* ,(reduce #'append(let*-bindings))
292 ,@(thunk (mv-bindings) (cdr (getters))))))))
294 (defmacro-mundanely push (obj place &environment env)
295 #!+sb-doc
296 "Takes an object and a location holding a list. Conses the object onto
297 the list, returning the modified list. OBJ is evaluated before PLACE."
298 ;; If PLACE has multiple store locations, what should we do?
299 ;; In other Lisp implementations:
300 ;; - One errs, says "Multiple store variables not expected"
301 ;; - One pushes multiple values produced by OBJ form into multiple places.
302 ;; - At least two produce an incorrect expansion that doesn't even work.
303 (expand-rmw-macro 'cons (list obj) place '() nil env '(item)))
305 (defmacro-mundanely pushnew (obj place &rest keys &environment env)
306 #!+sb-doc
307 "Takes an object and a location holding a list. If the object is
308 already in the list, does nothing; otherwise, conses the object onto
309 the list. Keyword arguments are accepted as per the ADJOIN function."
310 ;; Passing AFTER-ARGS-BINDP = NIL causes the forms subsequent to PLACE
311 ;; to be inserted literally as-is, giving the (apparently) desired behavior
312 ;; of *not* evaluating them before the Read/Modify/Write of PLACE, which
313 ;; seems to be an exception to the 5.1.3 exception on L-to-R evaluation.
314 ;; The spec only mentions that ITEM is eval'd before PLACE.
315 (expand-rmw-macro 'adjoin (list obj) place keys nil env '(item)))
317 (defmacro-mundanely pop (place &environment env)
318 #!+sb-doc
319 "The argument is a location holding a list. Pops one item off the front
320 of the list and returns it."
321 (if (symbolp (setq place (macroexpand-for-setf place env)))
322 `(prog1 (car ,place) (setq ,place (cdr ,place)))
323 (multiple-value-bind (temps vals stores setter getter)
324 (sb!xc:get-setf-expansion place env)
325 (let ((list (copy-symbol 'list))
326 (ret (copy-symbol 'car)))
327 `(let* (,@(mapcar #'list temps vals)
328 (,list ,getter)
329 (,ret (car ,list))
330 (,(car stores) (cdr ,list))
331 ,@(cdr stores))
332 ,setter
333 ,ret)))))
335 (defmacro-mundanely remf (place indicator &environment env)
336 #!+sb-doc
337 "Place may be any place expression acceptable to SETF, and is expected
338 to hold a property list or (). This list is destructively altered to
339 remove the property specified by the indicator. Returns T if such a
340 property was present, NIL if not."
341 (multiple-value-bind (temps vals newval setter getter)
342 (sb!xc:get-setf-expansion place env)
343 (let* ((flag (make-symbol "FLAG"))
344 (body `(multiple-value-bind (,(car newval) ,flag)
345 ;; See ANSI 5.1.3 for why we do out-of-order evaluation
346 (truly-the (values list boolean)
347 (%remf ,indicator ,getter))
348 ,(if (cdr newval) `(let ,(cdr newval) ,setter) setter)
349 ,flag)))
350 (if temps `(let* ,(mapcar #'list temps vals) ,body) body))))
352 ;; Perform the work of REMF.
353 (defun %remf (indicator plist)
354 (let ((tail plist) (predecessor))
355 (loop
356 (when (endp tail) (return (values plist nil)))
357 (let ((key (pop tail)))
358 (when (atom tail)
359 (error (if tail
360 "Improper list in REMF."
361 "Odd-length list in REMF.")))
362 (let ((next (cdr tail)))
363 (when (eq key indicator)
364 ;; This function is strict in its return type!
365 (the list next) ; for effect
366 (return (values (cond (predecessor
367 (setf (cdr predecessor) next)
368 plist)
370 next))
371 t)))
372 (setq predecessor tail tail next))))))
374 ;;; INCF and DECF have a straightforward expansion, avoiding temp vars,
375 ;;; when the PLACE is a non-macro symbol. Otherwise we do the generalized
376 ;;; SETF-like thing. The compiler doesn't care either way, but this
377 ;;; reduces the incentive to treat some macros as special-forms when
378 ;;; squeezing more performance from a Lisp interpreter.
379 ;;; DEFINE-MODIFY-MACRO could be used, but this expands more compactly.
380 (flet ((expand (place delta env operator)
381 (if (symbolp (setq place (macroexpand-for-setf place env)))
382 `(setq ,place (,operator ,delta ,place))
383 (multiple-value-bind (dummies vals newval setter getter)
384 (sb!xc:get-setf-expansion place env)
385 `(let* (,@(mapcar #'list dummies vals)
386 (,(car newval) (,operator ,delta ,getter))
387 ,@(cdr newval))
388 ,setter)))))
389 (defmacro-mundanely incf (place &optional (delta 1) &environment env)
390 #!+sb-doc
391 "The first argument is some location holding a number. This number is
392 incremented by the second argument, DELTA, which defaults to 1."
393 (expand place delta env '+))
395 (defmacro-mundanely decf (place &optional (delta 1) &environment env)
396 #!+sb-doc
397 "The first argument is some location holding a number. This number is
398 decremented by the second argument, DELTA, which defaults to 1."
399 (expand place delta env 'xsubtract)))
401 ;;;; DEFINE-MODIFY-MACRO stuff
403 (sb!xc:defmacro sb!xc:define-modify-macro (name lambda-list function &optional doc-string)
404 #!+sb-doc
405 "Creates a new read-modify-write macro like PUSH or INCF."
406 (binding* (((nil required optional rest)
407 (parse-lambda-list
408 lambda-list
409 :accept (lambda-list-keyword-mask '(&optional &rest))
410 :context "a DEFINE-MODIFY-MACRO lambda list"))
411 (args (append required
412 (mapcar (lambda (x) (if (listp x) (car x) x))
413 optional)))
414 (place (make-symbol "PLACE"))
415 (env (make-symbol "ENV")))
416 `(sb!xc:defmacro ,name (,place ,@lambda-list &environment ,env)
417 ,@(when doc-string (list (the string doc-string)))
418 (expand-rmw-macro ',function '() ,place
419 (list* ,@args ,(car rest)) t ,env ',args))))
421 ;;;; DEFSETF
423 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
424 ;;; Assign SETF macro information for NAME, making all appropriate checks.
425 (defun %defsetf (name expander inverse &optional doc)
426 (with-single-package-locked-error
427 (:symbol name "defining a setf-expander for ~A"))
428 (let ((setf-fn-name `(setf ,name)))
429 (multiple-value-bind (where-from present-p)
430 (info :function :where-from setf-fn-name)
431 ;; One might think that :DECLARED merits a style warning, but SBCL
432 ;; provides ~58 standard accessors as both (SETF F) and a macro.
433 ;; So allow the user to declaim an FTYPE and we'll hush up.
434 ;; What's good for the the goose is good for the gander.
435 (case where-from
436 (:assumed
437 ;; This indicates probable user error. Compilation assumed something
438 ;; to be functional; a macro says otherwise. Because :where-from's
439 ;; default can be :assumed, PRESENT-P disambiguates "defaulted" from
440 ;; "known" to have made an existence assumption.
441 (when present-p
442 (warn "defining setf macro for ~S when ~S was previously ~
443 treated as a function" name setf-fn-name)))
444 ;; This is a useless and unavoidable warning during self-build.
445 ;; cf. similar disabling of warning in WARN-IF-SETF-MACRO.
446 #-sb-xc-host
447 (:defined
448 ;; Somebody defined (SETF F) but then also said F has a macro.
449 ;; A soft warning seems appropriate because in this case it's
450 ;; at least in theory not wrong to call the function.
451 ;; The user can declare an FTYPE if both things are intentional.
452 (style-warn "defining setf macro for ~S when ~S is also defined"
453 name setf-fn-name)))))
454 (when inverse
455 (clear-info :setf :expander name)
456 (setf (info :setf :inverse name) inverse))
457 (when expander
458 (clear-info :setf :inverse name)
459 (setf (info :setf :expander name) expander))
460 (when doc
461 (setf (fdocumentation name 'setf) doc))
462 name))
464 (sb!xc:defmacro sb!xc:defsetf (access-fn &rest rest)
465 #!+sb-doc
466 "Associates a SETF update function or macro with the specified access
467 function or macro. The format is complex. See the manual for details."
468 (unless (symbolp access-fn)
469 (error "~S access-function name ~S is not a symbol."
470 'sb!xc:defsetf access-fn))
471 (typecase rest
472 ((cons (and symbol (not null)) (or null (cons string null)))
473 `(eval-when (:load-toplevel :compile-toplevel :execute)
474 (%defsetf ',access-fn nil ',(car rest) ,@(cdr rest))))
475 ((cons list (cons list))
476 (destructuring-bind (lambda-list (&rest stores) &body body) rest
477 (binding* (((llks req opt rest key aux env)
478 (parse-lambda-list
479 lambda-list
480 :accept (lambda-list-keyword-mask
481 '(&optional &rest &key &allow-other-keys
482 &environment))
483 :context "a DEFSETF lambda list"))
484 ((forms decls doc) (parse-body body t))
485 ((outer-decls inner-decls)
486 (extract-var-decls decls (append env stores)))
487 (subforms (copy-symbol 'subforms))
488 (env-var (if env (car env) (copy-symbol 'env)))
489 (lambda-list (make-lambda-list llks nil req opt rest key)))
490 (declare (ignore aux))
491 `(eval-when (:compile-toplevel :load-toplevel :execute)
492 (%defsetf ',access-fn
493 (cons ,(length stores)
494 (named-lambda (%defsetf ,access-fn)
495 (,subforms ,env-var ,@stores)
496 (declare (sb!c::lambda-list ,lambda-list))
497 ,@(if outer-decls (list outer-decls))
498 ,@(unless env `((declare (ignore ,env-var))))
499 (apply (lambda ,lambda-list
500 ,@inner-decls (block ,access-fn ,@forms))
501 ,subforms)))
502 nil ,@(and doc `(,doc)))))))
504 (error "Ill-formed DEFSETF for ~S" access-fn))))
506 ;; Given SEXPRS which is a list of things to evaluate, return four values:
507 ;; - a list of uninterned symbols to bind to any non-constant sexpr
508 ;; - a list of things to bind those symbols to
509 ;; - a list parallel to SEXPRS with each non-constant element
510 ;; replaced by its temporary variable from the first list.
511 ;; - a bitmask over the sexprs containing a 1 for each non-constant.
512 ;; Uninterned symbols are named according to the NAME-HINTS so that
513 ;; expansions use variables resembling the DEFSETF whence they came.
515 (defun collect-setf-temps (sexprs environment name-hints)
516 (labels ((next-name-hint ()
517 (let ((sym (pop name-hints))) ; OK if list was nil
518 (case sym
519 (&optional (next-name-hint))
520 ((&key &rest) (setq name-hints nil))
521 (t (if (listp sym) (car sym) sym)))))
522 (nice-tempname (form)
523 (acond ((next-name-hint) (copy-symbol it))
524 (t (gensymify form)))))
525 (collect ((temp-vars) (temp-vals) (call-arguments))
526 (let ((mask 0) (bit 1))
527 (dolist (form sexprs (values (temp-vars) (temp-vals) (call-arguments)
528 mask))
529 (call-arguments (if (sb!xc:constantp form environment)
530 (progn (next-name-hint) form) ; Skip one hint.
531 (let ((temp (nice-tempname form)))
532 (setq mask (logior mask bit))
533 (temp-vars temp)
534 (temp-vals form)
535 temp)))
536 (setq bit (ash bit 1)))))))
538 ;; Return the 5-part expansion of a SETF form defined by the long form
539 ;; of DEFSETF.
540 ;; FIXME: totally broken if there are keyword arguments. lp#1452947
541 (defun make-setf-quintuple (access-form environment num-store-vars expander)
542 (declare (type function expander))
543 (multiple-value-bind (temp-vars temp-vals call-arguments)
544 ;; FORMALS affect aesthetics only, not behavior.
545 (let ((formals #-sb-xc-host (%fun-lambda-list expander)))
546 (collect-setf-temps (cdr access-form) environment formals))
547 (let ((stores (let ((sb!xc:*gensym-counter* 1))
548 (make-gensym-list num-store-vars "NEW"))))
549 (values temp-vars temp-vals stores
550 (apply expander call-arguments environment stores)
551 `(,(car access-form) ,@call-arguments)))))
553 ;; Expand a macro defined by DEFINE-MODIFY-MACRO.
554 ;; The generated call resembles (FUNCTION <before-args> PLACE <after-args>)
555 ;; but the read/write of PLACE is done after all {BEFORE,AFTER}-ARG-FORMS are
556 ;; evaluated. Subforms of PLACE are evaluated in the usual order.
558 ;; Exception: See comment at PUSHNEW for the effect of AFTER-ARGS-BINDP = NIL.
559 (defun expand-rmw-macro (function before-arg-forms place after-arg-forms
560 after-args-bindp environment name-hints)
561 ;; Note that NAME-HINTS do the wrong thing if you have both "before" and
562 ;; "after" args. In that case it is probably best to specify them as ().
563 (binding* (((before-temps before-vals before-args)
564 (collect-setf-temps before-arg-forms environment name-hints))
565 ((place-temps place-subforms stores setter getter)
566 (sb!xc:get-setf-expansion place environment))
567 ((after-temps after-vals after-args)
568 (if after-args-bindp
569 (collect-setf-temps after-arg-forms environment name-hints)
570 (values nil nil after-arg-forms)))
571 (compute `(,function ,@before-args ,getter ,@after-args))
572 (set-fn (and (listp setter) (car setter)))
573 (newval-temp (car stores))
574 (newval-binding `((,newval-temp ,compute))))
575 ;; Elide the binding of NEWVAL-TEMP if it is ref'd exactly once
576 ;; and all the call arguments are temporaries and/or constants.
577 (when (and (= (count newval-temp setter) 1)
578 (or (eq set-fn 'setq)
579 (and (eq (info :function :kind set-fn) :function)
580 (every (lambda (x)
581 (or (member x place-temps)
582 (eq x newval-temp)
583 (sb!xc:constantp x environment)))
584 (cdr setter)))))
585 (setq newval-binding nil
586 setter (substitute compute newval-temp setter)))
587 (let ((bindings
588 (flet ((zip (list1 list2) (mapcar #'list list1 list2)))
589 (append (zip before-temps before-vals)
590 (zip place-temps place-subforms)
591 (zip after-temps after-vals)
592 newval-binding
593 (cdr stores)))))
594 (if bindings `(let* ,bindings ,setter) setter))))
596 ;;;; DEFMACRO DEFINE-SETF-EXPANDER and various DEFINE-SETF-EXPANDERs
598 ;;; DEFINE-SETF-EXPANDER is a lot like DEFMACRO.
599 (sb!xc:defmacro sb!xc:define-setf-expander (access-fn lambda-list &body body)
600 #!+sb-doc
601 "Syntax like DEFMACRO, but creates a setf expander function. The body
602 of the definition must be a form that returns five appropriate values."
603 (unless (symbolp access-fn)
604 (error "~S access-function name ~S is not a symbol."
605 'sb!xc:define-setf-expander access-fn))
606 (multiple-value-bind (def doc)
607 ;; Perhaps it would be more elegant to keep the docstring attached
608 ;; to the expander function, as for CAS?
609 (make-macro-lambda `(setf-expander ,access-fn) lambda-list body
610 'sb!xc:define-setf-expander access-fn
611 :doc-string-allowed :external)
612 `(eval-when (:compile-toplevel :load-toplevel :execute)
613 (%defsetf ',access-fn ,def nil ,@(and doc `(,doc))))))