(declaim (ftype (function (t &optional (or null sb!c::lexenv))) sb!xc:get-setf-expansion))
(defun sb!xc:get-setf-expansion (form &optional environment)
#!+sb-doc
- "Returns five values needed by the SETF machinery: a list of temporary
+ "Return five values needed by the SETF machinery: a list of temporary
variables, a list of values with which to fill them, a list of temporaries
for the new values, the setting function, and the accessing function."
(let (temp)
(cond ((symbolp form)
- (multiple-value-bind (expansion expanded)
- (sb!xc:macroexpand-1 form environment)
- (if expanded
- (sb!xc:get-setf-expansion expansion environment)
- (let ((new-var (gensym)))
- (values nil nil (list new-var)
- `(setq ,form ,new-var) form)))))
- ;; Local functions inhibit global SETF methods.
- ((and environment
- (let ((name (car form)))
- (dolist (x (sb!c::lexenv-functions environment))
- (when (and (eq (car x) name)
- (not (sb!c::defined-function-p (cdr x))))
- (return t)))))
- (expand-or-get-setf-inverse form environment))
- ((setq temp (info :setf :inverse (car form)))
- (get-setf-method-inverse form `(,temp) nil))
- ((setq temp (info :setf :expander (car form)))
- ;; KLUDGE: It may seem as though this should go through
- ;; *MACROEXPAND-HOOK*, but the ANSI spec seems fairly explicit
- ;; that *MACROEXPAND-HOOK* is a hook for MACROEXPAND-1, not
- ;; for macroexpansion in general. -- WHN 19991128
- (funcall temp
- form
- ;; As near as I can tell from the ANSI spec, macroexpanders
- ;; have a right to expect an actual lexical environment,
- ;; not just a NIL which is to be interpreted as a null
- ;; lexical environment. -- WHN 19991128
- (or environment (make-null-lexenv))))
- (t
- (expand-or-get-setf-inverse form environment)))))
-
-;;; GET-SETF-METHOD existed in pre-ANSI Common Lisp, and various code inherited
-;;; from CMU CL uses it repeatedly, so rather than rewrite a lot of code to not
-;;; use it, we just define it in terms of ANSI's GET-SETF-EXPANSION (or
-;;; actually, the cross-compiler version of that, i.e.
-;;; SB!XC:GET-SETF-EXPANSION).
-(declaim (ftype (function (t &optional (or null sb!c::lexenv))) get-setf-method))
-(defun get-setf-method (form &optional environment)
- #!+sb-doc
- "This is a specialized-for-one-value version of GET-SETF-EXPANSION (and
-a relic from pre-ANSI Common Lisp). Portable ANSI code should use
-GET-SETF-EXPANSION directly."
- (multiple-value-bind (temps value-forms store-vars store-form access-form)
- (sb!xc:get-setf-expansion form environment)
- (when (cdr store-vars)
- (error "GET-SETF-METHOD used for a form with multiple store ~
- variables:~% ~S"
- form))
- (values temps value-forms store-vars store-form access-form)))
+ (multiple-value-bind (expansion expanded)
+ (%macroexpand-1 form environment)
+ (if expanded
+ (sb!xc:get-setf-expansion expansion environment)
+ (let ((new-var (sb!xc:gensym "NEW")))
+ (values nil nil (list new-var)
+ `(setq ,form ,new-var) form)))))
+ ;; Local functions inhibit global SETF methods.
+ ((and environment
+ (let ((name (car form)))
+ (dolist (x (sb!c::lexenv-funs environment))
+ (when (and (eq (car x) name)
+ (not (sb!c::defined-fun-p (cdr x))))
+ (return t)))))
+ (expand-or-get-setf-inverse form environment))
+ ((setq temp (info :setf :inverse (car form)))
+ (get-setf-method-inverse form `(,temp) nil environment))
+ ((setq temp (info :setf :expander (car form)))
+ ;; KLUDGE: It may seem as though this should go through
+ ;; *MACROEXPAND-HOOK*, but the ANSI spec seems fairly explicit
+ ;; that *MACROEXPAND-HOOK* is a hook for MACROEXPAND-1, not
+ ;; for macroexpansion in general. -- WHN 19991128
+ (funcall temp
+ form
+ ;; As near as I can tell from the ANSI spec,
+ ;; macroexpanders have a right to expect an actual
+ ;; lexical environment, not just a NIL which is to
+ ;; be interpreted as a null lexical environment.
+ ;; -- WHN 19991128
+ (coerce-to-lexenv environment)))
+ (t
+ (expand-or-get-setf-inverse form environment)))))
;;; If a macro, expand one level and try again. If not, go for the
;;; SETF function.
-(declaim (ftype (function (t sb!c::lexenv)) expand-or-get-setf-inverse))
+(declaim (ftype (function (t (or null sb!c::lexenv)))
+ expand-or-get-setf-inverse))
(defun expand-or-get-setf-inverse (form environment)
(multiple-value-bind (expansion expanded)
- (sb!xc:macroexpand-1 form environment)
+ (%macroexpand-1 form environment)
(if expanded
- (sb!xc:get-setf-expansion expansion environment)
- (get-setf-method-inverse form
- `(funcall #'(setf ,(car form)))
- t))))
+ (sb!xc:get-setf-expansion expansion environment)
+ (get-setf-method-inverse form
+ `(funcall #'(setf ,(car form)))
+ t
+ environment))))
-(defun get-setf-method-inverse (form inverse setf-function)
- (let ((new-var (gensym))
- (vars nil)
- (vals nil))
- (dolist (x (cdr form))
- (push (gensym) vars)
- (push x vals))
- (setq vals (nreverse vals))
- (values vars vals (list new-var)
- (if setf-function
- `(,@inverse ,new-var ,@vars)
- `(,@inverse ,@vars ,new-var))
- `(,(car form) ,@vars))))
+(defun get-setf-method-inverse (form inverse setf-fun environment)
+ (let ((new-var (sb!xc:gensym "NEW"))
+ (vars nil)
+ (vals nil)
+ (args nil))
+ (dolist (x (reverse (cdr form)))
+ (cond ((sb!xc:constantp x environment)
+ (push x args))
+ (t
+ (let ((temp (gensymify x)))
+ (push temp args)
+ (push temp vars)
+ (push x vals)))))
+ (values vars
+ vals
+ (list new-var)
+ (if setf-fun
+ `(,@inverse ,new-var ,@args)
+ `(,@inverse ,@args ,new-var))
+ `(,(car form) ,@args))))
\f
;;;; SETF itself
-;;; Except for atoms, we always call GET-SETF-EXPANSION, since it has some
-;;; non-trivial semantics. But when there is a setf inverse, and G-S-E uses
-;;; it, then we return a call to the inverse, rather than returning a hairy let
-;;; form. This is probably important mainly as a convenience in allowing the
-;;; use of SETF inverses without the full interpreter.
+;;; Except for atoms, we always call GET-SETF-EXPANSION, since it has
+;;; some non-trivial semantics. But when there is a setf inverse, and
+;;; G-S-E uses it, then we return a call to the inverse, rather than
+;;; returning a hairy LET form. This is probably important mainly as a
+;;; convenience in allowing the use of SETF inverses without the full
+;;; interpreter.
(defmacro-mundanely setf (&rest args &environment env)
#!+sb-doc
"Takes pairs of arguments like SETQ. The first is a place and the second
(cond
((= nargs 2)
(let ((place (first args))
- (value-form (second args)))
- (if (atom place)
- `(setq ,place ,value-form)
- (multiple-value-bind (dummies vals newval setter getter)
- (sb!xc:get-setf-expansion place env)
- (declare (ignore getter))
- (let ((inverse (info :setf :inverse (car place))))
- (if (and inverse (eq inverse (car setter)))
- `(,inverse ,@(cdr place) ,value-form)
- `(let* (,@(mapcar #'list dummies vals))
- (multiple-value-bind ,newval ,value-form
- ,setter))))))))
+ (value-form (second args)))
+ (if (atom place)
+ `(setq ,place ,value-form)
+ (multiple-value-bind (dummies vals newval setter getter)
+ (sb!xc:get-setf-expansion place env)
+ (declare (ignore getter))
+ (let ((inverse (info :setf :inverse (car place))))
+ (if (and inverse (eq inverse (car setter)))
+ `(,inverse ,@(cdr place) ,value-form)
+ `(let* (,@(mapcar #'list dummies vals))
+ (multiple-value-bind ,newval ,value-form
+ ,setter))))))))
((oddp nargs)
(error "odd number of args to SETF"))
(t
(do ((a args (cddr a))
- (reversed-setfs nil))
- ((null a)
- `(progn ,@(nreverse reversed-setfs)))
- (push (list 'setf (car a) (cadr a)) reversed-setfs))))))
+ (reversed-setfs nil))
+ ((null a)
+ `(progn ,@(nreverse reversed-setfs)))
+ (push (list 'setf (car a) (cadr a)) reversed-setfs))))))
\f
;;;; various SETF-related macros
returning the value of the leftmost."
(when (< (length args) 2)
(error "~S called with too few arguments: ~S" 'shiftf form))
- (let ((resultvar (gensym)))
- (do ((arglist args (cdr arglist))
- (bindlist nil)
- (storelist nil)
- (lastvar resultvar))
- ((atom (cdr arglist))
- (push `(,lastvar ,(first arglist)) bindlist)
- `(let* ,(nreverse bindlist) ,@(nreverse storelist) ,resultvar))
- (multiple-value-bind (sm1 sm2 sm3 sm4 sm5)
- (get-setf-method (first arglist) env)
- (mapc #'(lambda (var val)
- (push `(,var ,val) bindlist))
- sm1
- sm2)
- (push `(,lastvar ,sm5) bindlist)
- (push sm4 storelist)
- (setq lastvar (first sm3))))))
+ (let (let*-bindings mv-bindings setters getters)
+ (dolist (arg (butlast args))
+ (multiple-value-bind (temps subforms store-vars setter getter)
+ (sb!xc:get-setf-expansion arg env)
+ (mapc (lambda (tmp form)
+ (push `(,tmp ,form) let*-bindings))
+ temps
+ subforms)
+ (push store-vars mv-bindings)
+ (push setter setters)
+ (push getter getters)))
+ ;; Handle the last arg specially here. The getter is just the last
+ ;; arg itself.
+ (push (car (last args)) getters)
+
+ ;; Reverse the collected lists so last bit looks nicer.
+ (setf let*-bindings (nreverse let*-bindings)
+ mv-bindings (nreverse mv-bindings)
+ setters (nreverse setters)
+ getters (nreverse getters))
+
+ (labels ((thunk (mv-bindings getters)
+ (if mv-bindings
+ `((multiple-value-bind
+ ,(car mv-bindings)
+ ,(car getters)
+ ,@(thunk (cdr mv-bindings) (cdr getters))))
+ `(,@setters))))
+ `(let ,let*-bindings
+ (multiple-value-bind ,(car mv-bindings)
+ ,(car getters)
+ ,@(thunk mv-bindings (cdr getters))
+ (values ,@(car mv-bindings)))))))
(defmacro-mundanely push (obj place &environment env)
#!+sb-doc
"Takes an object and a location holding a list. Conses the object onto
the list, returning the modified list. OBJ is evaluated before PLACE."
- (if (symbolp place)
- `(setq ,place (cons ,obj ,place))
- (multiple-value-bind
- (dummies vals newval setter getter)
- (get-setf-method place env)
- (let ((g (gensym)))
- `(let* ((,g ,obj)
- ,@(mapcar #'list dummies vals)
- (,(car newval) (cons ,g ,getter)))
- ,setter)))))
+ (multiple-value-bind (dummies vals newval setter getter)
+ (sb!xc:get-setf-expansion place env)
+ (let ((g (gensym)))
+ `(let* ((,g ,obj)
+ ,@(mapcar #'list dummies vals)
+ (,(car newval) (cons ,g ,getter))
+ ,@(cdr newval))
+ ,setter))))
-(defmacro-mundanely pushnew (obj place &rest keys &environment env)
+(defmacro-mundanely pushnew (obj place &rest keys
+ &key key test test-not &environment env)
#!+sb-doc
- "Takes an object and a location holding a list. If the object is already
- in the list, does nothing. Else, conses the object onto the list. Returns
- NIL. If there is a :TEST keyword, this is used for the comparison."
- (if (symbolp place)
- `(setq ,place (adjoin ,obj ,place ,@keys))
- (multiple-value-bind (dummies vals newval setter getter)
- (get-setf-method place env)
- (do* ((d dummies (cdr d))
- (v vals (cdr v))
- (let-list nil))
- ((null d)
- (push (list (car newval) `(adjoin ,obj ,getter ,@keys))
- let-list)
- `(let* ,(nreverse let-list)
- ,setter))
- (push (list (car d) (car v)) let-list)))))
+ "Takes an object and a location holding a list. If the object is
+ already in the list, does nothing; otherwise, conses the object onto
+ the list. Returns the modified list. If there is a :TEST keyword, this
+ is used for the comparison."
+ (declare (ignore key test test-not))
+ (multiple-value-bind (dummies vals newval setter getter)
+ (sb!xc:get-setf-expansion place env)
+ (let ((g (gensym)))
+ `(let* ((,g ,obj)
+ ,@(mapcar #'list dummies vals)
+ (,(car newval) (adjoin ,g ,getter ,@keys))
+ ,@(cdr newval))
+ ,setter))))
(defmacro-mundanely pop (place &environment env)
#!+sb-doc
"The argument is a location holding a list. Pops one item off the front
of the list and returns it."
- (if (symbolp place)
- `(prog1 (car ,place) (setq ,place (cdr ,place)))
- (multiple-value-bind (dummies vals newval setter getter)
- (get-setf-method place env)
- (do* ((d dummies (cdr d))
- (v vals (cdr v))
- (let-list nil))
- ((null d)
- (push (list (car newval) getter) let-list)
- `(let* ,(nreverse let-list)
- (prog1 (car ,(car newval))
- (setq ,(car newval) (cdr ,(car newval)))
- ,setter)))
- (push (list (car d) (car v)) let-list)))))
+ (multiple-value-bind (dummies vals newval setter getter)
+ (sb!xc:get-setf-expansion place env)
+ (let ((list-head (gensym)))
+ `(let* (,@(mapcar #'list dummies vals)
+ (,list-head ,getter)
+ (,(car newval) (cdr ,list-head))
+ ,@(cdr newval))
+ ,setter
+ (car ,list-head)))))
(defmacro-mundanely remf (place indicator &environment env)
#!+sb-doc
remove the property specified by the indicator. Returns T if such a
property was present, NIL if not."
(multiple-value-bind (dummies vals newval setter getter)
- (get-setf-method place env)
- (do* ((d dummies (cdr d))
- (v vals (cdr v))
- (let-list nil)
- (ind-temp (gensym))
- (local1 (gensym))
- (local2 (gensym)))
- ((null d)
- (push (list (car newval) getter) let-list)
- (push (list ind-temp indicator) let-list)
- `(let* ,(nreverse let-list)
- (do ((,local1 ,(car newval) (cddr ,local1))
- (,local2 nil ,local1))
- ((atom ,local1) nil)
- (cond ((atom (cdr ,local1))
- (error "Odd-length property list in REMF."))
- ((eq (car ,local1) ,ind-temp)
- (cond (,local2
- (rplacd (cdr ,local2) (cddr ,local1))
- (return t))
- (t (setq ,(car newval) (cddr ,(car newval)))
- ,setter
- (return t))))))))
- (push (list (car d) (car v)) let-list))))
+ (sb!xc:get-setf-expansion place env)
+ (let ((ind-temp (gensym))
+ (local1 (gensym))
+ (local2 (gensym)))
+ `(let* (,@(mapcar #'list dummies vals)
+ ;; See ANSI 5.1.3 for why we do out-of-order evaluation
+ (,ind-temp ,indicator)
+ (,(car newval) ,getter)
+ ,@(cdr newval))
+ (do ((,local1 ,(car newval) (cddr ,local1))
+ (,local2 nil ,local1))
+ ((atom ,local1) nil)
+ (cond ((atom (cdr ,local1))
+ (error "Odd-length property list in REMF."))
+ ((eq (car ,local1) ,ind-temp)
+ (cond (,local2
+ (rplacd (cdr ,local2) (cddr ,local1))
+ (return t))
+ (t (setq ,(car newval) (cddr ,(car newval)))
+ ,setter
+ (return t))))))))))
+
+;;; we can't use DEFINE-MODIFY-MACRO because of ANSI 5.1.3
+(defmacro-mundanely incf (place &optional (delta 1) &environment env)
+ #!+sb-doc
+ "The first argument is some location holding a number. This number is
+ incremented by the second argument, DELTA, which defaults to 1."
+ (multiple-value-bind (dummies vals newval setter getter)
+ (sb!xc:get-setf-expansion place env)
+ (let ((d (gensym)))
+ `(let* (,@(mapcar #'list dummies vals)
+ (,d ,delta)
+ (,(car newval) (+ ,getter ,d))
+ ,@(cdr newval))
+ ,setter))))
+
+(defmacro-mundanely decf (place &optional (delta 1) &environment env)
+ #!+sb-doc
+ "The first argument is some location holding a number. This number is
+ decremented by the second argument, DELTA, which defaults to 1."
+ (multiple-value-bind (dummies vals newval setter getter)
+ (sb!xc:get-setf-expansion place env)
+ (let ((d (gensym)))
+ `(let* (,@(mapcar #'list dummies vals)
+ (,d ,delta)
+ (,(car newval) (- ,getter ,d))
+ ,@(cdr newval))
+ ,setter))))
\f
;;;; DEFINE-MODIFY-MACRO stuff
#!+sb-doc
"Creates a new read-modify-write macro like PUSH or INCF."
(let ((other-args nil)
- (rest-arg nil)
- (env (gensym))
- (reference (gensym)))
+ (rest-arg nil)
+ (env (make-symbol "ENV")) ; To beautify resulting arglist.
+ (reference (make-symbol "PLACE"))) ; Note that these will be nonexistent
+ ; in the final expansion anyway.
;; Parse out the variable names and &REST arg from the lambda list.
(do ((ll lambda-list (cdr ll))
- (arg nil))
- ((null ll))
+ (arg nil))
+ ((null ll))
(setq arg (car ll))
(cond ((eq arg '&optional))
- ((eq arg '&rest)
- (if (symbolp (cadr ll))
- (setq rest-arg (cadr ll))
- (error "Non-symbol &REST argument in definition of ~S." name))
- (if (null (cddr ll))
- (return nil)
- (error "Illegal stuff after &REST argument.")))
- ((memq arg '(&key &allow-other-keys &aux))
- (error "~S not allowed in DEFINE-MODIFY-MACRO lambda list." arg))
- ((symbolp arg)
- (push arg other-args))
- ((and (listp arg) (symbolp (car arg)))
- (push (car arg) other-args))
- (t (error "Illegal stuff in lambda list."))))
+ ((eq arg '&rest)
+ (if (symbolp (cadr ll))
+ (setq rest-arg (cadr ll))
+ (error "Non-symbol &REST argument in definition of ~S." name))
+ (if (null (cddr ll))
+ (return nil)
+ (error "Illegal stuff after &REST argument.")))
+ ((memq arg '(&key &allow-other-keys &aux))
+ (error "~S not allowed in DEFINE-MODIFY-MACRO lambda list." arg))
+ ((symbolp arg)
+ (push arg other-args))
+ ((and (listp arg) (symbolp (car arg)))
+ (push (car arg) other-args))
+ (t (error "Illegal stuff in lambda list."))))
(setq other-args (nreverse other-args))
`(#-sb-xc-host sb!xc:defmacro
#+sb-xc-host defmacro-mundanely
- ,name (,reference ,@lambda-list &environment ,env)
+ ,name (,reference ,@lambda-list &environment ,env)
,doc-string
(multiple-value-bind (dummies vals newval setter getter)
- (get-setf-method ,reference ,env)
- (do ((d dummies (cdr d))
- (v vals (cdr v))
- (let-list nil (cons (list (car d) (car v)) let-list)))
- ((null d)
- (push (list (car newval)
- ,(if rest-arg
- `(list* ',function getter ,@other-args ,rest-arg)
- `(list ',function getter ,@other-args)))
- let-list)
- `(let* ,(nreverse let-list)
- ,setter)))))))
-
-(sb!xc:define-modify-macro incf (&optional (delta 1)) +
- #!+sb-doc
- "The first argument is some location holding a number. This number is
- incremented by the second argument, DELTA, which defaults to 1.")
-
-(sb!xc:define-modify-macro decf (&optional (delta 1)) -
- #!+sb-doc
- "The first argument is some location holding a number. This number is
- decremented by the second argument, DELTA, which defaults to 1.")
+ (sb!xc:get-setf-expansion ,reference ,env)
+ (let ()
+ `(let* (,@(mapcar #'list dummies vals)
+ (,(car newval)
+ ,,(if rest-arg
+ `(list* ',function getter ,@other-args ,rest-arg)
+ `(list ',function getter ,@other-args)))
+ ,@(cdr newval))
+ ,setter))))))
\f
;;;; DEFSETF
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
- ;;; Assign setf macro information for NAME, making all appropriate checks.
- (defun assign-setf-macro (name expander inverse doc)
+ ;;; Assign SETF macro information for NAME, making all appropriate checks.
+ (defun assign-setf-macro (name expander expander-lambda-list inverse doc)
+ #+sb-xc-host (declare (ignore expander-lambda-list))
+ (with-single-package-locked-error
+ (:symbol name "defining a setf-expander for ~A"))
(cond ((gethash name sb!c:*setf-assumed-fboundp*)
- (warn
- "defining setf macro for ~S when ~S was previously ~
- treated as a function"
- name
- `(setf ,name)))
- ((not (fboundp `(setf ,name)))
- ;; All is well, we don't need any warnings.
- (values))
- ((info :function :accessor-for name)
- (warn "defining SETF macro for DEFSTRUCT slot ~
- accessor; redefining as a normal function: ~S"
- name)
- (sb!c::proclaim-as-function-name name))
- ((not (eq (symbol-package name) (symbol-package 'aref)))
- (style-warn "defining setf macro for ~S when ~S is fbound"
- name `(setf ,name))))
+ (warn
+ "defining setf macro for ~S when ~S was previously ~
+ treated as a function"
+ name
+ `(setf ,name)))
+ ((not (fboundp `(setf ,name)))
+ ;; All is well, we don't need any warnings.
+ (values))
+ ((not (eq (symbol-package name) (symbol-package 'aref)))
+ (style-warn "defining setf macro for ~S when ~S is fbound"
+ name `(setf ,name))))
(remhash name sb!c:*setf-assumed-fboundp*)
+ #-sb-xc-host
+ (when expander
+ (setf (%fun-lambda-list expander) expander-lambda-list))
;; FIXME: It's probably possible to join these checks into one form which
;; is appropriate both on the cross-compilation host and on the target.
(when (or inverse (info :setf :inverse name))
#!+sb-doc
"Associates a SETF update function or macro with the specified access
function or macro. The format is complex. See the manual for details."
- (cond ((not (listp (car rest)))
- `(eval-when (:load-toplevel :compile-toplevel :execute)
- (assign-setf-macro ',access-fn
- nil
- ',(car rest)
- ,(when (and (car rest) (stringp (cadr rest)))
- `',(cadr rest)))))
- ((and (cdr rest) (listp (cadr rest)))
- (destructuring-bind
- (lambda-list (&rest store-variables) &body body)
- rest
- (let ((arglist-var (gensym "ARGS-"))
- (access-form-var (gensym "ACCESS-FORM-"))
- (env-var (gensym "ENVIRONMENT-")))
- (multiple-value-bind (body local-decs doc)
- (parse-defmacro `(,lambda-list ,@store-variables)
- arglist-var body access-fn 'defsetf
- :anonymousp t)
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (assign-setf-macro
- ',access-fn
- #'(lambda (,access-form-var ,env-var)
- (declare (ignore ,env-var))
- (%defsetf ,access-form-var ,(length store-variables)
- #'(lambda (,arglist-var)
- ,@local-decs
- (block ,access-fn
- ,body))))
- nil
- ',doc))))))
- (t
- (error "ill-formed DEFSETF for ~S" access-fn))))
+ (cond ((and (not (listp (car rest))) (symbolp (car rest)))
+ `(eval-when (:load-toplevel :compile-toplevel :execute)
+ (assign-setf-macro ',access-fn
+ nil
+ nil
+ ',(car rest)
+ ,(when (and (car rest) (stringp (cadr rest)))
+ `',(cadr rest)))))
+ ((and (cdr rest) (listp (cadr rest)))
+ (destructuring-bind
+ (lambda-list (&rest store-variables) &body body)
+ rest
+ (with-unique-names (whole access-form environment)
+ (multiple-value-bind (body local-decs doc)
+ (parse-defmacro `(,lambda-list ,@store-variables)
+ whole body access-fn 'defsetf
+ :environment environment
+ :anonymousp t)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (assign-setf-macro
+ ',access-fn
+ (lambda (,access-form ,environment)
+ ,@local-decs
+ (%defsetf ,access-form ,(length store-variables)
+ (lambda (,whole)
+ ,body)))
+ ',lambda-list
+ nil
+ ',doc))))))
+ (t
+ (error "ill-formed DEFSETF for ~S" access-fn))))
(defun %defsetf (orig-access-form num-store-vars expander)
+ (declare (type function expander))
(let (subforms
- subform-vars
- subform-exprs
- store-vars)
+ subform-vars
+ subform-exprs
+ store-vars)
(dolist (subform (cdr orig-access-form))
(if (constantp subform)
- (push subform subforms)
- (let ((var (gensym)))
- (push var subforms)
- (push var subform-vars)
- (push subform subform-exprs))))
+ (push subform subforms)
+ (let ((var (gensym)))
+ (push var subforms)
+ (push var subform-vars)
+ (push subform subform-exprs))))
(dotimes (i num-store-vars)
(push (gensym) store-vars))
(let ((r-subforms (nreverse subforms))
- (r-subform-vars (nreverse subform-vars))
- (r-subform-exprs (nreverse subform-exprs))
- (r-store-vars (nreverse store-vars)))
+ (r-subform-vars (nreverse subform-vars))
+ (r-subform-exprs (nreverse subform-exprs))
+ (r-store-vars (nreverse store-vars)))
(values r-subform-vars
- r-subform-exprs
- r-store-vars
- (funcall expander (cons r-subforms r-store-vars))
- `(,(car orig-access-form) ,@r-subforms)))))
+ r-subform-exprs
+ r-store-vars
+ (funcall expander (cons r-subforms r-store-vars))
+ `(,(car orig-access-form) ,@r-subforms)))))
\f
;;;; DEFMACRO DEFINE-SETF-EXPANDER and various DEFINE-SETF-EXPANDERs
;;; DEFINE-SETF-EXPANDER is a lot like DEFMACRO.
(def!macro sb!xc:define-setf-expander (access-fn lambda-list &body body)
#!+sb-doc
- "Syntax like DEFMACRO, but creates a Setf-Method generator. The body
- must be a form that returns the five magical values."
+ "Syntax like DEFMACRO, but creates a setf expander function. The body
+ of the definition must be a form that returns five appropriate values."
(unless (symbolp access-fn)
- (error "DEFINE-SETF-EXPANDER access-function name ~S is not a symbol."
- access-fn))
- (let ((whole (gensym "WHOLE-"))
- (environment (gensym "ENV-")))
+ (error "~S access-function name ~S is not a symbol."
+ 'sb!xc:define-setf-expander access-fn))
+ (with-unique-names (whole environment)
(multiple-value-bind (body local-decs doc)
- (parse-defmacro lambda-list whole body access-fn
- 'sb!xc:define-setf-expander
- :environment environment)
+ (parse-defmacro lambda-list whole body access-fn
+ 'sb!xc:define-setf-expander
+ :environment environment)
`(eval-when (:compile-toplevel :load-toplevel :execute)
- (assign-setf-macro ',access-fn
- #'(lambda (,whole ,environment)
- ,@local-decs
- (block ,access-fn ,body))
- nil
- ',doc)))))
+ (assign-setf-macro ',access-fn
+ (lambda (,whole ,environment)
+ ,@local-decs
+ ,body)
+ ',lambda-list
+ nil
+ ',doc)))))
(sb!xc:define-setf-expander getf (place prop
- &optional default
- &environment env)
+ &optional default
+ &environment env)
(declare (type sb!c::lexenv env))
(multiple-value-bind (temps values stores set get)
- (get-setf-method place env)
+ (sb!xc:get-setf-expansion place env)
(let ((newval (gensym))
- (ptemp (gensym))
- (def-temp (if default (gensym))))
+ (ptemp (gensym))
+ (def-temp (if default (gensym))))
(values `(,@temps ,ptemp ,@(if default `(,def-temp)))
- `(,@values ,prop ,@(if default `(,default)))
- `(,newval)
- `(let ((,(car stores) (%putf ,get ,ptemp ,newval)))
- ,set
- ,newval)
- `(getf ,get ,ptemp ,@(if default `(,def-temp)))))))
+ `(,@values ,prop ,@(if default `(,default)))
+ `(,newval)
+ `(let ((,(car stores) (%putf ,get ,ptemp ,newval))
+ ,@(cdr stores))
+ ,def-temp ;; prevent unused style-warning
+ ,set
+ ,newval)
+ `(getf ,get ,ptemp ,@(if default `(,def-temp)))))))
(sb!xc:define-setf-expander get (symbol prop &optional default)
(let ((symbol-temp (gensym))
- (prop-temp (gensym))
- (def-temp (gensym))
- (newval (gensym)))
+ (prop-temp (gensym))
+ (def-temp (if default (gensym)))
+ (newval (gensym)))
(values `(,symbol-temp ,prop-temp ,@(if default `(,def-temp)))
- `(,symbol ,prop ,@(if default `(,default)))
- (list newval)
- `(%put ,symbol-temp ,prop-temp ,newval)
- `(get ,symbol-temp ,prop-temp ,@(if default `(,def-temp))))))
+ `(,symbol ,prop ,@(if default `(,default)))
+ (list newval)
+ `(progn ,def-temp ;; prevent unused style-warning
+ (%put ,symbol-temp ,prop-temp ,newval))
+ `(get ,symbol-temp ,prop-temp ,@(if default `(,def-temp))))))
(sb!xc:define-setf-expander gethash (key hashtable &optional default)
(let ((key-temp (gensym))
- (hashtable-temp (gensym))
- (default-temp (gensym))
- (new-value-temp (gensym)))
+ (hashtable-temp (gensym))
+ (default-temp (if default (gensym)))
+ (new-value-temp (gensym)))
(values
`(,key-temp ,hashtable-temp ,@(if default `(,default-temp)))
`(,key ,hashtable ,@(if default `(,default)))
`(,new-value-temp)
- `(%puthash ,key-temp ,hashtable-temp ,new-value-temp)
+ `(progn ,default-temp ;; prevent unused style-warning
+ (%puthash ,key-temp ,hashtable-temp ,new-value-temp))
`(gethash ,key-temp ,hashtable-temp ,@(if default `(,default-temp))))))
(sb!xc:define-setf-expander logbitp (index int &environment env)
(declare (type sb!c::lexenv env))
(multiple-value-bind (temps vals stores store-form access-form)
- (get-setf-method int env)
+ (sb!xc:get-setf-expansion int env)
(let ((ind (gensym))
- (store (gensym))
- (stemp (first stores)))
+ (store (gensym))
+ (stemp (first stores)))
(values `(,ind ,@temps)
- `(,index
- ,@vals)
- (list store)
- `(let ((,stemp
- (dpb (if ,store 1 0) (byte 1 ,ind) ,access-form)))
- ,store-form
- ,store)
- `(logbitp ,ind ,access-form)))))
+ `(,index
+ ,@vals)
+ (list store)
+ `(let ((,stemp
+ (dpb (if ,store 1 0) (byte 1 ,ind) ,access-form))
+ ,@(cdr stores))
+ ,store-form
+ ,store)
+ `(logbitp ,ind ,access-form)))))
;;; CMU CL had a comment here that:
;;; Evil hack invented by the gnomes of Vassar Street (though not as evil as
;;; ANSI has some place for SETF APPLY. -- WHN 19990604
(sb!xc:define-setf-expander apply (functionoid &rest args)
(unless (and (listp functionoid)
- (= (length functionoid) 2)
- (eq (first functionoid) 'function)
- (symbolp (second functionoid)))
+ (= (length functionoid) 2)
+ (eq (first functionoid) 'function)
+ (symbolp (second functionoid)))
(error "SETF of APPLY is only defined for function args like #'SYMBOL."))
(let ((function (second functionoid))
- (new-var (gensym))
- (vars (make-gensym-list (length args))))
+ (new-var (gensym))
+ (vars (make-gensym-list (length args))))
(values vars args (list new-var)
- `(apply #'(setf ,function) ,new-var ,@vars)
- `(apply #',function ,@vars))))
+ `(apply #'(setf ,function) ,new-var ,@vars)
+ `(apply #',function ,@vars))))
;;; Special-case a BYTE bytespec so that the compiler can recognize it.
(sb!xc:define-setf-expander ldb (bytespec place &environment env)
#!+sb-doc
"The first argument is a byte specifier. The second is any place form
- acceptable to SETF. Replaces the specified byte of the number in this
- place with bits from the low-order end of the new value."
+acceptable to SETF. Replace the specified byte of the number in this
+place with bits from the low-order end of the new value."
(declare (type sb!c::lexenv env))
(multiple-value-bind (dummies vals newval setter getter)
- (get-setf-method place env)
+ (sb!xc:get-setf-expansion place env)
(if (and (consp bytespec) (eq (car bytespec) 'byte))
- (let ((n-size (gensym))
- (n-pos (gensym))
- (n-new (gensym)))
- (values (list* n-size n-pos dummies)
- (list* (second bytespec) (third bytespec) vals)
- (list n-new)
- `(let ((,(car newval) (dpb ,n-new (byte ,n-size ,n-pos)
- ,getter)))
- ,setter
- ,n-new)
- `(ldb (byte ,n-size ,n-pos) ,getter)))
- (let ((btemp (gensym))
- (gnuval (gensym)))
- (values (cons btemp dummies)
- (cons bytespec vals)
- (list gnuval)
- `(let ((,(car newval) (dpb ,gnuval ,btemp ,getter)))
- ,setter
- ,gnuval)
- `(ldb ,btemp ,getter))))))
+ (let ((n-size (gensym))
+ (n-pos (gensym))
+ (n-new (gensym)))
+ (values (list* n-size n-pos dummies)
+ (list* (second bytespec) (third bytespec) vals)
+ (list n-new)
+ `(let ((,(car newval) (dpb ,n-new (byte ,n-size ,n-pos)
+ ,getter))
+ ,@(cdr newval))
+ ,setter
+ ,n-new)
+ `(ldb (byte ,n-size ,n-pos) ,getter)))
+ (let ((btemp (gensym))
+ (gnuval (gensym)))
+ (values (cons btemp dummies)
+ (cons bytespec vals)
+ (list gnuval)
+ `(let ((,(car newval) (dpb ,gnuval ,btemp ,getter)))
+ ,setter
+ ,gnuval)
+ `(ldb ,btemp ,getter))))))
(sb!xc:define-setf-expander mask-field (bytespec place &environment env)
#!+sb-doc
"The first argument is a byte specifier. The second is any place form
- acceptable to SETF. Replaces the specified byte of the number in this place
- with bits from the corresponding position in the new value."
+acceptable to SETF. Replaces the specified byte of the number in this place
+with bits from the corresponding position in the new value."
(declare (type sb!c::lexenv env))
(multiple-value-bind (dummies vals newval setter getter)
- (get-setf-method place env)
+ (sb!xc:get-setf-expansion place env)
(let ((btemp (gensym))
- (gnuval (gensym)))
+ (gnuval (gensym)))
(values (cons btemp dummies)
- (cons bytespec vals)
- (list gnuval)
- `(let ((,(car newval) (deposit-field ,gnuval ,btemp ,getter)))
- ,setter
- ,gnuval)
- `(mask-field ,btemp ,getter)))))
+ (cons bytespec vals)
+ (list gnuval)
+ `(let ((,(car newval) (deposit-field ,gnuval ,btemp ,getter))
+ ,@(cdr newval))
+ ,setter
+ ,gnuval)
+ `(mask-field ,btemp ,getter)))))
-(sb!xc:define-setf-expander the (type place &environment env)
+(defun setf-expand-the (the type place env)
(declare (type sb!c::lexenv env))
- (multiple-value-bind (dummies vals newval setter getter)
- (get-setf-method place env)
- (values dummies
- vals
- newval
- (subst `(the ,type ,(car newval)) (car newval) setter)
- `(the ,type ,getter))))
+ (multiple-value-bind (temps subforms store-vars setter getter)
+ (sb!xc:get-setf-expansion place env)
+ (values temps subforms store-vars
+ `(multiple-value-bind ,store-vars
+ (,the ,type (values ,@store-vars))
+ ,setter)
+ `(,the ,type ,getter))))
+
+(sb!xc:define-setf-expander the (type place &environment env)
+ (setf-expand-the 'the type place env))
+
+(sb!xc:define-setf-expander truly-the (type place &environment env)
+ (setf-expand-the 'truly-the type place env))