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
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 ;;; The inverse for a generalized-variable reference function is stored in
22 ;;; A SETF inverse property corresponds to the short form of DEFSETF. It is
23 ;;; the name of a function takes the same args as the reference form, plus a
24 ;;; new-value arg at the end.
26 ;;; A SETF method expander is created by the long form of DEFSETF or
27 ;;; by DEFINE-SETF-EXPANDER. It is a function that is called on the reference
28 ;;; form and that produces five values: a list of temporary variables, a list
29 ;;; of value forms, a list of the single store-value form, a storing function,
30 ;;; and an accessing function.
31 (declaim (ftype (function (t &optional lexenv-designator
))
32 sb
!xc
:get-setf-expansion
))
33 (defun sb!xc
:get-setf-expansion
(form &optional environment
)
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."
39 (multiple-value-bind (expansion expanded
)
40 (sb!xc
:macroexpand-1 form environment
)
42 (sb!xc
:get-setf-expansion expansion environment
)
43 (let ((store (sb!xc
:gensym
"NEW")))
44 (values nil nil
(list store
) `(setq ,form
,store
) form
))))
45 (let ((name (car form
)))
46 (flet ((expand (call arg-maker
)
47 ;; Produce the expansion of a SETF form that calls either
48 ;; #'(SETF name) or an inverse given by short form DEFSETF.
49 (multiple-value-bind (temp-vars temp-vals args
)
50 (collect-setf-temps (cdr form
) environment nil
)
51 (let ((store (sb!xc
:gensym
"NEW")))
52 (values temp-vars temp-vals
(list store
)
53 `(,.call
,@(funcall arg-maker store args
))
55 ;; Local functions inhibit global SETF methods.
56 (unless (sb!c
::fun-locally-defined-p name environment
)
57 (acond ((info :setf
:inverse name
)
58 (return-from sb
!xc
:get-setf-expansion
59 (expand `(,it
) (lambda (new args
) `(,@args
,new
)))))
60 ((info :setf
:expander name
)
61 (return-from sb
!xc
:get-setf-expansion
63 (make-setf-quintuple form environment
65 (funcall it form environment
))))))
66 ;; When NAME is a macro, retry from the top.
67 ;; Otherwise default to the function named `(SETF ,name).
68 (multiple-value-bind (expansion expanded
)
69 (%macroexpand-1 form environment
)
71 (sb!xc
:get-setf-expansion expansion environment
)
72 (expand `(funcall #'(setf ,name
)) #'cons
)))))))
74 ;; Expand PLACE until it is a form that SETF might know something about.
75 ;; Macros are expanded only when no SETF expander (or inverse) exists.
76 ;; Symbol-macros are always expanded because there are no SETF expanders
77 ;; for them. This is useful mainly when a symbol-macro or ordinary macro
78 ;; expands to a "mundane" lexical or special variable.
79 (defun macroexpand-for-setf (place environment
)
81 (when (and (listp place
)
82 (let ((op (car place
)))
83 (or (info :setf
:expander op
) (info :setf
:inverse op
))))
85 (multiple-value-bind (expansion macro-p
) (%macroexpand-1 place environment
)
87 (setq place expansion
) ; iterate
92 ;; Code shared by SETF, PSETF, SHIFTF attempting to minimize the expansion.
93 ;; This has significant speed+space benefit to a non-preprocessing interpreter,
94 ;; and to some degree a preprocessing interpreter.
95 (labels ((gen-let* (bindings body-forms
)
96 (cond ((not bindings
) body-forms
)
98 (when (and (singleton-p body-forms
)
99 (listp (car body-forms
))
100 (eq (caar body-forms
) 'let
*))
101 (let ((nested (cdar body-forms
))) ; extract the nested LET*
102 (setq bindings
(append bindings
(car nested
))
103 body-forms
(cdr nested
))))
104 `((let* ,bindings
,@body-forms
)))))
105 (gen-mv-bind (stores values body-forms
)
106 (if (singleton-p stores
)
107 (gen-let* `((,(car stores
) ,values
)) body-forms
)
108 `((multiple-value-bind ,stores
,values
,@body-forms
))))
110 (if (and (consp form
) (eq (car form
) 'progn
))
113 ;; Instead of emitting (PROGN (VALUES (SETQ ...) (SETQ ...)) NIL)
114 ;; the SETQs can be lifted into the PROGN. This is unimportant
115 ;; for compiled code, but it helps the interpreter not needlessly
116 ;; collect arguments to call VALUES; and it's more human-readable.
117 (de-values-ify (forms)
118 (mapcan (lambda (form)
119 (if (and (listp form
) (eq (car form
) 'values
))
120 (copy-list (cdr form
))
124 (defmacro-mundanely setf
(&whole form
&rest args
&environment env
)
126 "Takes pairs of arguments like SETQ. The first is a place and the second
127 is the value that is supposed to go into that place. Returns the last
128 value. The place argument may be any of the access forms for which SETF
129 knows a corresponding setting form."
131 (return-from setf nil
))
132 (destructuring-bind (place value-form . more
) args
134 (return-from setf
`(progn ,@(sb!c
::explode-setq form
'error
))))
135 (when (symbolp (setq place
(macroexpand-for-setf place env
)))
136 (return-from setf
`(setq ,place
,value-form
)))
137 (let* ((fun (car place
))
138 (inverse (info :setf
:inverse fun
)))
139 (when (and inverse
(not (sb!c
::fun-locally-defined-p fun env
)))
140 (return-from setf
`(,inverse
,@(cdr place
) ,value-form
))))
141 (multiple-value-bind (temps vals newval setter
)
142 (sb!xc
:get-setf-expansion place env
)
143 (car (gen-let* (mapcar #'list temps vals
)
144 (gen-mv-bind newval value-form
(forms-list setter
)))))))
146 ;; various SETF-related macros
148 (defmacro-mundanely shiftf
(&whole form
&rest args
&environment env
)
150 "One or more SETF-style place expressions, followed by a single
151 value expression. Evaluates all of the expressions in turn, then
152 assigns the value of each expression to the place on its left,
153 returning the value of the leftmost."
154 (declare (type sb
!c
::lexenv env
))
155 (when (< (length args
) 2)
156 (error "~S called with too few arguments: ~S" 'shiftf form
))
157 (collect ((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 (let-bindings (mapcar #'list temps subforms
))
162 (mv-bindings store-vars
)
165 ;; Handle the last arg specially here. The getter is just the last
167 (getters (car (last args
)))
168 (labels ((thunk (mv-bindings getters setters
)
170 (gen-mv-bind (car mv-bindings
) (car getters
)
171 (thunk (cdr mv-bindings
) (cdr getters
) setters
))
173 (let ((outputs (loop for i below
(length (car (mv-bindings)))
174 collect
(sb!xc
:gensym
"OUT"))))
175 `(let ,(reduce #'append
(let-bindings))
176 ,@(gen-mv-bind outputs
(car (getters))
177 (thunk (mv-bindings) (cdr (getters))
178 `(,@(de-values-ify (setters))
179 (values ,@outputs
)))))))))
182 ((expand (args env operator single-op
)
183 (cond ((singleton-p (cdr args
)) ; commonest case probably
184 (return-from expand
`(progn (,single-op
,@args
) nil
)))
186 (return-from expand nil
)))
187 (collect ((let*-bindings
) (mv-bindings) (setters))
188 (do ((a args
(cddr a
)))
191 (error "Odd number of args to ~S." operator
))
192 (let ((place (car a
))
193 (value-form (cadr a
)))
194 (when (and (not (symbolp place
)) (eq operator
'psetq
))
195 (error 'simple-program-error
196 :format-control
"Place ~S in PSETQ is not a SYMBOL"
197 :format-arguments
(list place
)))
198 (multiple-value-bind (temps vals stores setter
)
199 (sb!xc
:get-setf-expansion place env
)
200 (let*-bindings
(mapcar #'list temps vals
))
201 (mv-bindings (cons stores value-form
))
203 (car (build (let*-bindings
) (mv-bindings)
204 (de-values-ify (setters))))))
205 (build (let*-bindings mv-bindings setters
)
207 (gen-let* (car let
*-bindings
)
208 (gen-mv-bind (caar mv-bindings
) (cdar mv-bindings
)
209 (build (cdr let
*-bindings
) (cdr mv-bindings
)
213 (defmacro-mundanely psetf
(&rest pairs
&environment env
)
215 "This is to SETF as PSETQ is to SETQ. Args are alternating place
216 expressions and values to go into those places. All of the subforms and
217 values are determined, left to right, and only then are the locations
218 updated. Returns NIL."
219 (expand pairs env
'psetf
'setf
))
221 (defmacro-mundanely psetq
(&rest pairs
&environment env
)
224 Set the variables to the values, like SETQ, except that assignments
225 happen in parallel, i.e. no assignments take place until all the
226 forms have been evaluated."
227 (expand pairs env
'psetq
'setq
))))
229 ;;; FIXME: Compiling this definition of ROTATEF apparently blows away the
230 ;;; definition in the cross-compiler itself, so that after that, any
231 ;;; ROTATEF operations can no longer be compiled, because
232 ;;; GET-SETF-EXPANSION is called instead of SB!XC:GET-SETF-EXPANSION.
233 (defmacro-mundanely rotatef
(&rest args
&environment env
)
235 "Takes any number of SETF-style place expressions. Evaluates all of the
236 expressions in turn, then assigns to each place the value of the form to
237 its right. The rightmost form gets the value of the leftmost.
239 (declare (type sb
!c
::lexenv env
))
241 (collect ((let*-bindings
) (mv-bindings) (setters) (getters))
243 (multiple-value-bind (temps subforms store-vars setter getter
)
244 (sb!xc
:get-setf-expansion arg env
)
245 (let*-bindings
(mapcar #'list temps subforms
))
246 (mv-bindings store-vars
)
250 (getters (car (getters)))
251 (labels ((thunk (mv-bindings getters
)
253 `((multiple-value-bind ,(car mv-bindings
) ,(car getters
)
254 ,@(thunk (cdr mv-bindings
) (cdr getters
))))
256 `(let* ,(reduce #'append
(let*-bindings
))
257 ,@(thunk (mv-bindings) (cdr (getters))))))))
259 (defmacro-mundanely push
(obj place
&environment env
)
261 "Takes an object and a location holding a list. Conses the object onto
262 the list, returning the modified list. OBJ is evaluated before PLACE."
263 ;; If PLACE has multiple store locations, what should we do?
264 ;; In other Lisp implementations:
265 ;; - One errs, says "Multiple store variables not expected"
266 ;; - One pushes multiple values produced by OBJ form into multiple places.
267 ;; - At least two produce an incorrect expansion that doesn't even work.
268 (expand-rmw-macro 'cons
(list obj
) place
'() nil env
'(item)))
270 (defmacro-mundanely pushnew
(obj place
&rest keys
&environment env
)
272 "Takes an object and a location holding a list. If the object is
273 already in the list, does nothing; otherwise, conses the object onto
274 the list. Keyword arguments are accepted as per the ADJOIN function."
275 ;; Passing AFTER-ARGS-BINDP = NIL causes the forms subsequent to PLACE
276 ;; to be inserted literally as-is, giving the (apparently) desired behavior
277 ;; of *not* evaluating them before the Read/Modify/Write of PLACE, which
278 ;; seems to be an exception to the 5.1.3 exception on L-to-R evaluation.
279 ;; The spec only mentions that ITEM is eval'd before PLACE.
280 (expand-rmw-macro 'adjoin
(list obj
) place keys nil env
'(item)))
282 (defmacro-mundanely pop
(place &environment env
)
284 "The argument is a location holding a list. Pops one item off the front
285 of the list and returns it."
286 (if (symbolp (setq place
(macroexpand-for-setf place env
)))
287 `(prog1 (car ,place
) (setq ,place
(cdr ,place
)))
288 (multiple-value-bind (temps vals stores setter getter
)
289 (sb!xc
:get-setf-expansion place env
)
290 (let ((list (copy-symbol 'list
))
291 (ret (copy-symbol 'car
)))
292 `(let* (,@(mapcar #'list temps vals
)
295 (,(car stores
) (cdr ,list
))
300 (defmacro-mundanely remf
(place indicator
&environment env
)
302 "Place may be any place expression acceptable to SETF, and is expected
303 to hold a property list or (). This list is destructively altered to
304 remove the property specified by the indicator. Returns T if such a
305 property was present, NIL if not."
306 (multiple-value-bind (temps vals newval setter getter
)
307 (sb!xc
:get-setf-expansion place env
)
308 (let* ((flag (make-symbol "FLAG"))
309 (body `(multiple-value-bind (,(car newval
) ,flag
)
310 ;; See ANSI 5.1.3 for why we do out-of-order evaluation
311 (truly-the (values list boolean
)
312 (%remf
,indicator
,getter
))
313 ,(if (cdr newval
) `(let ,(cdr newval
) ,setter
) setter
)
315 (if temps
`(let* ,(mapcar #'list temps vals
) ,body
) body
))))
317 ;; Perform the work of REMF.
318 (defun %remf
(indicator plist
)
319 (let ((tail plist
) (predecessor))
321 (when (endp tail
) (return (values plist nil
)))
322 (let ((key (pop tail
)))
325 "Improper list in REMF."
326 "Odd-length list in REMF.")))
327 (let ((next (cdr tail
)))
328 (when (eq key indicator
)
329 ;; This function is strict in its return type!
330 (the list next
) ; for effect
331 (return (values (cond (predecessor
332 (setf (cdr predecessor
) next
)
337 (setq predecessor tail tail next
))))))
339 ;;; INCF and DECF have a straightforward expansion, avoiding temp vars,
340 ;;; when the PLACE is a non-macro symbol. Otherwise we do the generalized
341 ;;; SETF-like thing. The compiler doesn't care either way, but this
342 ;;; reduces the incentive to treat some macros as special-forms when
343 ;;; squeezing more performance from a Lisp interpreter.
344 ;;; DEFINE-MODIFY-MACRO could be used, but this expands more compactly.
345 (flet ((expand (place delta env operator
)
346 (if (symbolp (setq place
(macroexpand-for-setf place env
)))
347 `(setq ,place
(,operator
,delta
,place
))
348 (multiple-value-bind (dummies vals newval setter getter
)
349 (sb!xc
:get-setf-expansion place env
)
350 `(let* (,@(mapcar #'list dummies vals
)
351 (,(car newval
) (,operator
,delta
,getter
))
354 (defmacro-mundanely incf
(place &optional
(delta 1) &environment env
)
356 "The first argument is some location holding a number. This number is
357 incremented by the second argument, DELTA, which defaults to 1."
358 (expand place delta env
'+))
360 (defmacro-mundanely decf
(place &optional
(delta 1) &environment env
)
362 "The first argument is some location holding a number. This number is
363 decremented by the second argument, DELTA, which defaults to 1."
364 (expand place delta env
'xsubtract
)))
366 ;;;; DEFINE-MODIFY-MACRO stuff
368 (def!macro sb
!xc
:define-modify-macro
(name lambda-list function
&optional doc-string
)
370 "Creates a new read-modify-write macro like PUSH or INCF."
371 (binding* (((llks required optional rest
)
374 :accept
(lambda-list-keyword-mask '(&optional
&rest
))
375 :context
"a DEFINE-MODIFY-MACRO lambda list"))
376 (args (append required
377 (mapcar (lambda (x) (if (listp x
) (car x
) x
))
379 (place (make-symbol "PLACE"))
380 (env (make-symbol "ENV")))
381 (declare (ignore llks
))
382 `(#-sb-xc-host sb
!xc
:defmacro
383 #+sb-xc-host defmacro-mundanely
384 ,name
(,place
,@lambda-list
&environment
,env
)
385 ,@(when doc-string
(list (the string doc-string
)))
386 (expand-rmw-macro ',function
'() ,place
387 (list* ,@args
,(car rest
)) t
,env
',args
))))
391 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
392 ;;; Assign SETF macro information for NAME, making all appropriate checks.
393 (macrolet ((assign-it ()
396 (clear-info :setf
:expander name
)
397 (setf (info :setf
:inverse name
) inverse
))
399 (clear-info :setf
:inverse name
)
400 (setf (info :setf
:expander name
) expander
))
402 (setf (fdocumentation name
'setf
) doc
))
404 (defun %defsetf
(name expander inverse
&optional doc
)
405 (with-single-package-locked-error
406 (:symbol name
"defining a setf-expander for ~A"))
407 (let ((setf-fn-name `(setf ,name
)))
408 (multiple-value-bind (where-from present-p
)
409 (info :function
:where-from setf-fn-name
)
410 ;; One might think that :DECLARED merits a style warning, but SBCL
411 ;; provides ~58 standard accessors as both (SETF F) and a macro.
412 ;; So allow the user to declaim an FTYPE and we'll hush up.
413 ;; What's good for the the goose is good for the gander.
416 ;; This indicates probable user error. Compilation assumed something
417 ;; to be functional; a macro says otherwise. Because :where-from's
418 ;; default can be :assumed, PRESENT-P disambiguates "defaulted" from
419 ;; "known" to have made an existence assumption.
421 (warn "defining setf macro for ~S when ~S was previously ~
422 treated as a function" name setf-fn-name
)))
423 ;; This is a useless and unavoidable warning during self-build.
424 ;; cf. similar disabling of warning in WARN-IF-SETF-MACRO.
427 ;; Somebody defined (SETF F) but then also said F has a macro.
428 ;; A soft warning seems appropriate because in this case it's
429 ;; at least in theory not wrong to call the function.
430 ;; The user can declare an FTYPE if both things are intentional.
431 (style-warn "defining setf macro for ~S when ~S is also defined"
432 name setf-fn-name
)))))
434 ;; For cold-init, because any warning will cause a crash.
435 (defun !quietly-defsetf
(name expander inverse
&optional doc
)
438 (def!macro sb
!xc
:defsetf
(access-fn &rest rest
)
440 "Associates a SETF update function or macro with the specified access
441 function or macro. The format is complex. See the manual for details."
442 (unless (symbolp access-fn
)
443 (error "~S access-function name ~S is not a symbol."
444 'sb
!xc
:defsetf access-fn
))
446 ((cons (and symbol
(not null
)) (or null
(cons string null
)))
447 `(eval-when (:load-toplevel
:compile-toplevel
:execute
)
448 (%defsetf
',access-fn nil
',(car rest
) ,@(cdr rest
))))
449 ((cons list
(cons list
))
450 (destructuring-bind (lambda-list (&rest stores
) &body body
) rest
451 (binding* (((llks req opt rest key aux env
)
454 :accept
(lambda-list-keyword-mask
455 '(&optional
&rest
&key
&allow-other-keys
457 :context
"a DEFSETF lambda list"))
458 ((forms decls doc
) (parse-body body
))
459 ((outer-decls inner-decls
)
460 (extract-var-decls decls
(append env stores
)))
461 (subforms (copy-symbol 'subforms
))
462 (env-var (if env
(car env
) (copy-symbol 'env
)))
463 (lambda-list (make-lambda-list llks nil req opt rest key
)))
464 (declare (ignore aux
))
465 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
466 (%defsetf
',access-fn
467 (cons ,(length stores
)
468 (named-lambda (%defsetf
,access-fn
)
469 (,subforms
,env-var
,@stores
)
470 (declare (sb!c
::lambda-list
,lambda-list
))
471 ,@(if outer-decls
(list outer-decls
))
472 ,@(unless env
`((declare (ignore ,env-var
))))
473 (apply (lambda ,lambda-list
474 ,@inner-decls
(block ,access-fn
,@forms
))
476 nil
,@(and doc
`(,doc
)))))))
478 (error "Ill-formed DEFSETF for ~S" access-fn
))))
480 ;; Given SEXPRS which is a list of things to evaluate, return four values:
481 ;; - a list of uninterned symbols to bind to any non-constant sexpr
482 ;; - a list of things to bind those symbols to
483 ;; - a list parallel to SEXPRS with each non-constant element
484 ;; replaced by its temporary variable from the first list.
485 ;; - a bitmask over the sexprs containing a 1 for each non-constant.
486 ;; Uninterned symbols are named according to the NAME-HINTS so that
487 ;; expansions use variables resembling the DEFSETF whence they came.
489 (defun collect-setf-temps (sexprs environment name-hints
)
490 (labels ((next-name-hint ()
491 (let ((sym (pop name-hints
))) ; OK if list was nil
493 (&optional
(next-name-hint))
494 ((&key
&rest
) (setq name-hints nil
))
495 (t (if (listp sym
) (car sym
) sym
)))))
496 (nice-tempname (form)
497 (acond ((next-name-hint) (copy-symbol it
))
498 (t (gensymify form
)))))
499 (collect ((temp-vars) (temp-vals) (call-arguments))
500 (let ((mask 0) (bit 1))
501 (dolist (form sexprs
(values (temp-vars) (temp-vals) (call-arguments)
503 (call-arguments (if (sb!xc
:constantp form environment
)
504 (progn (next-name-hint) form
) ; Skip one hint.
505 (let ((temp (nice-tempname form
)))
506 (setq mask
(logior mask bit
))
510 (setq bit
(ash bit
1)))))))
512 ;; Return the 5-part expansion of a SETF form defined by the long form
514 ;; FIXME: totally broken if there are keyword arguments. lp#1452947
515 (defun make-setf-quintuple (access-form environment num-store-vars expander
)
516 (declare (type function expander
))
517 (multiple-value-bind (temp-vars temp-vals call-arguments
)
518 ;; FORMALS affect aesthetics only, not behavior.
519 (let ((formals #-sb-xc-host
(%fun-lambda-list expander
)))
520 (collect-setf-temps (cdr access-form
) environment formals
))
521 (let ((stores (let ((sb!xc
:*gensym-counter
* 1))
522 (make-gensym-list num-store-vars
"NEW"))))
523 (values temp-vars temp-vals stores
524 (apply expander call-arguments environment stores
)
525 `(,(car access-form
) ,@call-arguments
)))))
527 ;; Expand a macro defined by DEFINE-MODIFY-MACRO.
528 ;; The generated call resembles (FUNCTION <before-args> PLACE <after-args>)
529 ;; but the read/write of PLACE is done after all {BEFORE,AFTER}-ARG-FORMS are
530 ;; evaluated. Subforms of PLACE are evaluated in the usual order.
532 ;; Exception: See comment at PUSHNEW for the effect of AFTER-ARGS-BINDP = NIL.
533 (defun expand-rmw-macro (function before-arg-forms place after-arg-forms
534 after-args-bindp environment name-hints
)
535 ;; Note that NAME-HINTS do the wrong thing if you have both "before" and
536 ;; "after" args. In that case it is probably best to specify them as ().
537 (binding* (((before-temps before-vals before-args
)
538 (collect-setf-temps before-arg-forms environment name-hints
))
539 ((place-temps place-subforms stores setter getter
)
540 (sb!xc
:get-setf-expansion place environment
))
541 ((after-temps after-vals after-args
)
543 (collect-setf-temps after-arg-forms environment name-hints
)
544 (values nil nil after-arg-forms
)))
545 (compute `(,function
,@before-args
,getter
,@after-args
))
546 (set-fn (and (listp setter
) (car setter
)))
547 (newval-temp (car stores
))
548 (newval-binding `((,newval-temp
,compute
))))
549 ;; Elide the binding of NEWVAL-TEMP if it is ref'd exactly once
550 ;; and all the call arguments are temporaries and/or constants.
551 (when (and (= (count newval-temp setter
) 1)
552 (or (eq set-fn
'setq
)
553 (and (eq (info :function
:kind set-fn
) :function
)
555 (or (member x place-temps
)
557 (sb!xc
:constantp x environment
)))
559 (setq newval-binding nil
560 setter
(substitute compute newval-temp setter
)))
562 (flet ((zip (list1 list2
) (mapcar #'list list1 list2
)))
563 (append (zip before-temps before-vals
)
564 (zip place-temps place-subforms
)
565 (zip after-temps after-vals
)
568 (if bindings
`(let* ,bindings
,setter
) setter
))))
570 ;;;; DEFMACRO DEFINE-SETF-EXPANDER and various DEFINE-SETF-EXPANDERs
572 ;;; DEFINE-SETF-EXPANDER is a lot like DEFMACRO.
573 (def!macro sb
!xc
:define-setf-expander
(access-fn lambda-list
&body body
)
575 "Syntax like DEFMACRO, but creates a setf expander function. The body
576 of the definition must be a form that returns five appropriate values."
577 (unless (symbolp access-fn
)
578 (error "~S access-function name ~S is not a symbol."
579 'sb
!xc
:define-setf-expander access-fn
))
580 (multiple-value-bind (def doc
)
581 ;; Perhaps it would be more elegant to keep the docstring attached
582 ;; to the expander function, as for CAS?
583 (make-macro-lambda `(setf-expander ,access-fn
) lambda-list body
584 'sb
!xc
:define-setf-expander access-fn
585 :doc-string-allowed
:external
)
586 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
587 (%defsetf
',access-fn
,def nil
,@(and doc
`(,doc
))))))
589 (sb!xc
:define-setf-expander values
(&rest places
&environment env
)
590 (declare (type sb
!c
::lexenv env
))
591 (collect ((setters) (getters))
592 (let ((all-dummies '())
595 (dolist (place places
)
596 (multiple-value-bind (dummies vals newval setter getter
)
597 (sb!xc
:get-setf-expansion place env
)
598 ;; ANSI 5.1.2.3 explains this logic quite precisely. --
600 (setq all-dummies
(append all-dummies dummies
(cdr newval
))
601 all-vals
(append all-vals vals
602 (mapcar (constantly nil
) (cdr newval
)))
603 newvals
(append newvals
(list (car newval
))))
606 (values all-dummies all-vals newvals
607 `(values ,@(setters)) `(values ,@(getters))))))
609 (sb!xc
:define-setf-expander getf
(place prop
&optional default
&environment env
)
610 (declare (type sb
!c
::lexenv env
))
611 (binding* (((place-tempvars place-tempvals stores set get
)
612 (sb!xc
:get-setf-expansion place env
))
613 ((call-tempvars call-tempvals call-args bitmask
)
614 (collect-setf-temps (list prop default
) env
'(indicator default
)))
615 (newval (gensym "NEW")))
616 (values `(,@place-tempvars
,@call-tempvars
)
617 `(,@place-tempvals
,@call-tempvals
)
619 `(let ((,(car stores
) (%putf
,get
,(first call-args
) ,newval
))
621 ;; prevent "unused variable" style-warning
622 ,@(when (logbitp 1 bitmask
) (last call-tempvars
))
625 `(getf ,get
,@call-args
))))
627 ;; CLHS Notes on DEFSETF say that: "A setf of a call on access-fn also evaluates
628 ;; all of access-fn's arguments; it cannot treat any of them specially."
629 ;; An implication is that even though the DEFAULT argument to GET,GETHASH serves
630 ;; no purpose except when used in a R/M/W context such as PUSH, you can't elide
631 ;; it. In particular, this must fail: (SETF (GET 'SYM 'IND (ERROR "Foo")) 3).
633 (sb!xc
:defsetf get
(symbol indicator
&optional default
&environment e
) (newval)
634 (let ((constp (sb!xc
:constantp default e
)))
635 ;; always reference default's temp var to "use" it
636 `(%put
,symbol
,indicator
,(if constp newval
`(progn ,default
,newval
)))))
638 ;; A possible optimization for read/modify/write of GETHASH
639 ;; would be to predetermine the vector element where the key/value pair goes.
640 (sb!xc
:defsetf gethash
(key hashtable
&optional default
&environment e
) (newval)
641 (let ((constp (sb!xc
:constantp default e
)))
642 ;; always reference default's temp var to "use" it
643 `(%puthash
,key
,hashtable
,(if constp newval
`(progn ,default
,newval
)))))
645 (sb!xc
:defsetf slot-value sb
!pcl
::set-slot-value
)
647 ;;; CMU CL had a comment here that:
648 ;;; Evil hack invented by the gnomes of Vassar Street (though not as evil as
649 ;;; it used to be.) The function arg must be constant, and is converted to
650 ;;; an APPLY of the SETF function, which ought to exist.
652 ;;; Historical note: The hack was considered evil becase prior to the
653 ;;; standardization of #'(SETF F) as a namespace for functions, all that existed
654 ;;; were SETF expanders. To "invert" (APPLY #'F A B .. LAST), you assumed that
655 ;;; the SETF expander was ok to use on (F A B .. LAST), yielding something
656 ;;; like (set-F A B .. LAST). If the LAST arg didn't move (based on comparing
657 ;;; gensyms between the "getter" and "setter" forms), you'd stick APPLY
658 ;;; in front and hope for the best. Plus AREF still had to be special-cased.
660 ;;; It may not be clear (wasn't to me..) that this is a standard thing, but See
661 ;;; "5.1.2.5 APPLY Forms as Places" in the ANSI spec. I haven't actually
662 ;;; verified that this code has any correspondence to that code, but at least
663 ;;; ANSI has some place for SETF APPLY. -- WHN 19990604
664 (sb!xc
:define-setf-expander apply
(functionoid &rest args
)
665 ;; Technically (per CLHS) this only must allow AREF,BIT,SBIT
666 ;; but there's not much danger in allowing other stuff.
667 (unless (typep functionoid
'(cons (eql function
) (cons symbol null
)))
668 (error "SETF of APPLY is only defined for function args like #'SYMBOL."))
669 (let ((function (second functionoid
))
671 (vars (make-gensym-list (length args
))))
672 (values vars args
(list new-var
)
673 `(apply #'(setf ,function
) ,new-var
,@vars
)
674 `(apply #',function
,@vars
))))
676 ;;; Perform expansion of SETF on LDB, MASK-FIELD, or LOGBITP.
677 ;;; It is preferable to destructure the BYTE form and bind temp vars to its
678 ;;; parts rather than bind a temp for its result. (See the source transforms
679 ;;; for LDB/DPB). But for constant arguments to BYTE, we don't need any temp.
680 (defun setf-expand-ldb (bytespec-form place env store-fun load-fun
)
681 (binding* ((spec (%macroexpand bytespec-form env
))
682 ((byte-tempvars byte-tempvals byte-args
)
683 (if (typep spec
'(cons (eql byte
)
684 (and (not (cons integer
(cons integer
)))
685 (cons t
(cons t null
)))))
686 (collect-setf-temps (cdr spec
) env
'(size pos
))
687 (collect-setf-temps (list spec
) env
'(bytespec))))
688 (byte (if (cdr byte-args
) (cons 'byte byte-args
) (car byte-args
)))
689 ((place-tempvars place-tempvals stores setter getter
)
690 (sb!xc
:get-setf-expansion place env
))
691 (newval (sb!xc
:gensym
"NEW"))
692 (new-int `(,store-fun
693 ,(if (eq load-fun
'logbitp
) `(if ,newval
1 0) newval
)
695 (values `(,@byte-tempvars
,@place-tempvars
)
696 `(,@byte-tempvals
,@place-tempvals
)
698 ;; FIXME: expand-rmw-macro has code for determining whether
699 ;; a binding of a "newval" can be elided.
700 (if (and (typep setter
'(cons (eql setq
)
701 (cons symbol
(cons t null
))))
703 (eq (third setter
) (first stores
)))
704 `(progn (setq ,(second setter
) ,new-int
) ,newval
)
705 `(let ((,(car stores
) ,new-int
) ,@(cdr stores
))
708 (if (eq load-fun
'logbitp
)
709 ;; If there was a temp for the POS, then use it.
710 ;; Otherwise use the constant POS from the original spec.
711 `(logbitp ,(or (car byte-tempvars
) (third spec
)) ,getter
)
712 `(,load-fun
,byte
,getter
)))))
714 ;;; SETF of LOGBITP is not mandated by CLHS but is nice to have.
715 ;;; FIXME: the code is suboptimal. Better code would "pre-shift" the 1 bit,
716 ;;; so that result = (in & ~mask) | (flag ? mask : 0)
717 ;;; Additionally (setf (logbitp N x) t) is extremely stupid- it first clears
718 ;;; and then sets the bit, though it does manage to pre-shift the constants.
719 (sb!xc
:define-setf-expander logbitp
(index place
&environment env
)
720 (setf-expand-ldb `(byte 1 ,index
) place env
'dpb
'logbitp
))
722 ;;; Special-case a BYTE bytespec so that the compiler can recognize it.
723 ;;; FIXME: it is suboptimal that (INCF (LDB (BYTE 9 0) (ELT X 0)))
724 ;;; performs two reads of (ELT X 0), once to get the value from which
725 ;;; to extract a 9-bit subfield, and again to combine the incremented
726 ;;; value with the other bits. I don't think it's wrong per se,
727 ;;; but is worthy of some thought as to whether it can be improved.
728 (sb!xc
:define-setf-expander ldb
(bytespec place
&environment env
)
730 "The first argument is a byte specifier. The second is any place form
731 acceptable to SETF. Replace the specified byte of the number in this
732 place with bits from the low-order end of the new value."
733 (setf-expand-ldb bytespec place env
'dpb
'ldb
))
735 (sb!xc
:define-setf-expander mask-field
(bytespec place
&environment env
)
737 "The first argument is a byte specifier. The second is any place form
738 acceptable to SETF. Replaces the specified byte of the number in this place
739 with bits from the corresponding position in the new value."
740 (setf-expand-ldb bytespec place env
'deposit-field
'mask-field
))
742 (defun setf-expand-the (the type place env
)
743 (declare (type sb
!c
::lexenv env
))
744 (multiple-value-bind (temps subforms store-vars setter getter
)
745 (sb!xc
:get-setf-expansion place env
)
746 (values temps subforms store-vars
747 `(multiple-value-bind ,store-vars
748 (,the
,type
(values ,@store-vars
))
750 `(,the
,type
,getter
))))
752 (sb!xc
:define-setf-expander the
(type place
&environment env
)
753 (setf-expand-the 'the type place env
))
755 (sb!xc
:define-setf-expander truly-the
(type place
&environment env
)
756 (setf-expand-the 'truly-the type place env
))