(let (temp)
(cond ((symbolp form)
(multiple-value-bind (expansion expanded)
- (sb!xc:macroexpand-1 form environment)
+ (%macroexpand-1 form environment)
(if expanded
(sb!xc:get-setf-expansion expansion environment)
- (let ((new-var (gensym)))
+ (let ((new-var (sb!xc:gensym "NEW")))
(values nil nil (list new-var)
`(setq ,form ,new-var) form)))))
;; Local functions inhibit global SETF methods.
(return t)))))
(expand-or-get-setf-inverse form environment))
((setq temp (info :setf :inverse (car form)))
- (get-setf-method-inverse form `(,temp) nil))
+ (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
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))))
+ t
+ environment))))
-(defun get-setf-method-inverse (form inverse setf-fun)
- (let ((new-var (gensym))
+(defun get-setf-method-inverse (form inverse setf-fun environment)
+ (let ((new-var (sb!xc:gensym "NEW"))
(vars nil)
- (vals nil))
- (dolist (x (cdr form))
- (push (gensym) vars)
- (push x vals))
- (setq vals (nreverse vals))
- (values vars vals (list new-var)
+ (vals nil)
+ (args nil))
+ (dolist (x (reverse (cdr form)))
+ (cond ((sb!xc:constantp x environment)
+ (push x args))
+ (t
+ (let ((temp (gensym "TMP")))
+ (push temp args)
+ (push temp vars)
+ (push x vals)))))
+ (values vars
+ vals
+ (list new-var)
(if setf-fun
- `(,@inverse ,new-var ,@vars)
- `(,@inverse ,@vars ,new-var))
- `(,(car form) ,@vars))))
+ `(,@inverse ,new-var ,@args)
+ `(,@inverse ,@args ,new-var))
+ `(,(car form) ,@args))))
\f
;;;; SETF itself
(,(car newval) (cons ,g ,getter)))
,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; 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)
(get-setf-method place env)
(let ((g (gensym)))
"Creates a new read-modify-write macro like PUSH or INCF."
(let ((other-args nil)
(rest-arg nil)
- (env (gensym))
- (reference (gensym)))
+ (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))
#!+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)))
+ (cond ((and (not (listp (car rest))) (symbolp (car rest)))
`(eval-when (:load-toplevel :compile-toplevel :execute)
(assign-setf-macro ',access-fn
nil
(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-")))
+ (with-unique-names (whole access-form environment)
(multiple-value-bind (body local-decs doc)
(parse-defmacro `(,lambda-list ,@store-variables)
- arglist-var body access-fn 'defsetf
+ whole body access-fn 'defsetf
+ :environment environment
: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
+ (lambda (,access-form ,environment)
+ ,@local-decs
+ (%defsetf ,access-form ,(length store-variables)
+ (lambda (,whole)
,body)))
nil
',doc))))))
,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 (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))
+ (,the ,type (values ,@store-vars))
,setter)
- `(the ,type ,getter))))
+ `(,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))
projects / sbcl.git / blobdiff