1 ;;;; SETF and friends (except for stuff defined with COLLECT, which
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.
9 ;;;; This software is part of the SBCL system. See the README file for
10 ;;;; more information.
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.
18 (in-package "SB!IMPL")
23 ;;; The inverse for a generalized-variable reference function is stored in
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.
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)
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."
43 (multiple-value-bind (expansion expanded)
44 (sb!xc:macroexpand-1 form environment)
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.
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))))
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
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))))
73 (expand-or-get-setf-inverse form environment)))))
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)
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 ~
92 (values temps value-forms store-vars store-form access-form)))
94 ;;; If a macro, expand one level and try again. If not, go for the
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)
101 (sb!xc:get-setf-expansion expansion environment)
102 (get-setf-method-inverse form
103 `(funcall #'(setf ,(car form)))
106 (defun get-setf-method-inverse (form inverse setf-function)
107 (let ((new-var (gensym))
110 (dolist (x (cdr form))
113 (setq vals (nreverse vals))
114 (values vars vals (list new-var)
116 `(,@inverse ,new-var ,@vars)
117 `(,@inverse ,@vars ,new-var))
118 `(,(car form) ,@vars))))
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)
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)))
136 (let ((place (first args))
137 (value-form (second args)))
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
150 (error "odd number of args to SETF"))
152 (do ((a args (cddr a))
153 (reversed-setfs nil))
155 `(progn ,@(nreverse reversed-setfs)))
156 (push (list 'setf (car a) (cadr a)) reversed-setfs))))))
158 ;;;; various SETF-related macros
160 (defmacro-mundanely shiftf (&whole form &rest args &environment env)
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))
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))
182 (push `(,lastvar ,sm5) bindlist)
184 (setq lastvar (first sm3))))))
186 (defmacro-mundanely push (obj place &environment env)
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."
191 `(setq ,place (cons ,obj ,place))
193 (dummies vals newval setter getter)
194 (get-setf-method place env)
197 ,@(mapcar #'list dummies vals)
198 (,(car newval) (cons ,g ,getter)))
201 (defmacro-mundanely pushnew (obj place &rest keys &environment env)
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."
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))
214 (push (list (car newval) `(adjoin ,obj ,getter ,@keys))
216 `(let* ,(nreverse let-list)
218 (push (list (car d) (car v)) let-list)))))
220 (defmacro-mundanely pop (place &environment env)
222 "The argument is a location holding a list. Pops one item off the front
223 of the list and returns it."
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))
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)))
237 (push (list (car d) (car v)) let-list)))))
239 (defmacro-mundanely remf (place indicator &environment env)
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))
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))
260 (cond ((atom (cdr ,local1))
261 (error "Odd-length property list in REMF."))
262 ((eq (car ,local1) ,ind-temp)
264 (rplacd (cdr ,local2) (cddr ,local1))
266 (t (setq ,(car newval) (cddr ,(car newval)))
269 (push (list (car d) (car v)) let-list))))
271 ;;;; DEFINE-MODIFY-MACRO stuff
273 (def!macro sb!xc:define-modify-macro (name lambda-list function &optional doc-string)
275 "Creates a new read-modify-write macro like PUSH or INCF."
276 (let ((other-args nil)
279 (reference (gensym)))
280 ;; Parse out the variable names and &REST arg from the lambda list.
281 (do ((ll lambda-list (cdr ll))
285 (cond ((eq arg '&optional))
287 (if (symbolp (cadr ll))
288 (setq rest-arg (cadr ll))
289 (error "Non-symbol &REST arg in definition of ~S." name))
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))
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)
305 (multiple-value-bind (dummies vals newval setter getter)
306 (get-setf-method ,reference ,env)
307 (do ((d dummies (cdr d))
309 (let-list nil (cons (list (car d) (car v)) let-list)))
311 (push (list (car newval)
313 `(list* ',function getter ,@other-args ,rest-arg)
314 `(list ',function getter ,@other-args)))
316 `(let* ,(nreverse let-list)
319 (sb!xc:define-modify-macro incf (&optional (delta 1)) +
321 "The first argument is some location holding a number. This number is
322 incremented by the second argument, DELTA, which defaults to 1.")
324 (sb!xc:define-modify-macro decf (&optional (delta 1)) -
326 "The first argument is some location holding a number. This number is
327 decremented by the second argument, DELTA, which defaults to 1.")
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*)
336 "defining setf macro for ~S when ~S was previously ~
337 treated as a function"
340 ((not (fboundp `(setf ,name)))
341 ;; All is well, we don't need any warnings.
343 ((info :function :accessor-for name)
344 (warn "defining SETF macro for DEFSTRUCT slot ~
345 accessor; redefining as a normal function: ~S"
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))
359 (setf (fdocumentation name 'setf) doc))
362 (def!macro sb!xc:defsetf (access-fn &rest rest)
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
371 ,(when (and (car rest) (stringp (cadr rest)))
373 ((and (cdr rest) (listp (cadr rest)))
375 (lambda-list (&rest store-variables) &body body)
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
384 `(eval-when (:compile-toplevel :load-toplevel :execute)
387 #'(lambda (,access-form-var ,env-var)
388 (declare (ignore ,env-var))
389 (%defsetf ,access-form-var ,(length store-variables)
390 #'(lambda (,arglist-var)
397 (error "ill-formed DEFSETF for ~S" access-fn))))
399 (defun %defsetf (orig-access-form num-store-vars expander)
404 (dolist (subform (cdr orig-access-form))
405 (if (constantp subform)
406 (push subform subforms)
407 (let ((var (gensym)))
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
420 (funcall expander (cons r-subforms r-store-vars))
421 `(,(car orig-access-form) ,@r-subforms)))))
423 ;;;; DEFMACRO DEFINE-SETF-EXPANDER and various DEFINE-SETF-EXPANDERs
425 ;;; DEFINE-SETF-EXPANDER is a lot like DEFMACRO.
426 (def!macro sb!xc:define-setf-expander (access-fn lambda-list &body body)
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."
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)
443 (block ,access-fn ,body))
447 (sb!xc:define-setf-expander getf (place prop
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))
455 (def-temp (if default (gensym))))
456 (values `(,@temps ,ptemp ,@(if default `(,def-temp)))
457 `(,@values ,prop ,@(if default `(,default)))
459 `(let ((,(car stores) (%putf ,get ,ptemp ,newval)))
462 `(getf ,get ,ptemp ,@(if default `(,def-temp)))))))
464 (sb!xc:define-setf-expander get (symbol prop &optional default)
465 (let ((symbol-temp (gensym))
469 (values `(,symbol-temp ,prop-temp ,@(if default `(,def-temp)))
470 `(,symbol ,prop ,@(if default `(,default)))
472 `(%put ,symbol-temp ,prop-temp ,newval)
473 `(get ,symbol-temp ,prop-temp ,@(if default `(,def-temp))))))
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)))
481 `(,key-temp ,hashtable-temp ,@(if default `(,default-temp)))
482 `(,key ,hashtable ,@(if default `(,default)))
484 `(%puthash ,key-temp ,hashtable-temp ,new-value-temp)
485 `(gethash ,key-temp ,hashtable-temp ,@(if default `(,default-temp))))))
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)
493 (stemp (first stores)))
494 (values `(,ind ,@temps)
499 (dpb (if ,store 1 0) (byte 1 ,ind) ,access-form)))
502 `(logbitp ,ind ,access-form)))))
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.
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))
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))))
526 ;;; Special-case a BYTE bytespec so that the compiler can recognize it.
527 (sb!xc:define-setf-expander ldb (bytespec place &environment env)
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))
539 (values (list* n-size n-pos dummies)
540 (list* (second bytespec) (third bytespec) vals)
542 `(let ((,(car newval) (dpb ,n-new (byte ,n-size ,n-pos)
546 `(ldb (byte ,n-size ,n-pos) ,getter)))
547 (let ((btemp (gensym))
549 (values (cons btemp dummies)
552 `(let ((,(car newval) (dpb ,gnuval ,btemp ,getter)))
555 `(ldb ,btemp ,getter))))))
557 (sb!xc:define-setf-expander mask-field (bytespec place &environment env)
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))
567 (values (cons btemp dummies)
570 `(let ((,(car newval) (deposit-field ,gnuval ,btemp ,getter)))
573 `(mask-field ,btemp ,getter)))))
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)
582 (subst `(the ,type ,(car newval)) (car newval) setter)
583 `(the ,type ,getter))))