X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-setf.lisp;h=0c20fefcc8d93d22de5ec53e1a0ffa578f6d28ee;hb=4084b6b95c1d5e0a45e073a9b875d8471efd8505;hp=ee7cc7d84d4edc01f3a062ea17ec4738fb690137;hpb=8bcffb407835ff680d5ee2ba1f7ce97839bbae3e;p=sbcl.git diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp index ee7cc7d..0c20fef 100644 --- a/src/code/early-setf.lisp +++ b/src/code/early-setf.lisp @@ -38,10 +38,10 @@ (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. @@ -53,7 +53,7 @@ (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 @@ -95,26 +95,34 @@ GET-SETF-EXPANSION directly." 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)))) ;;;; SETF itself @@ -211,12 +219,14 @@ GET-SETF-EXPANSION directly." (,(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))) @@ -307,8 +317,9 @@ GET-SETF-EXPANSION directly." "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)) @@ -382,7 +393,7 @@ GET-SETF-EXPANSION directly." #!+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 @@ -393,21 +404,19 @@ GET-SETF-EXPANSION directly." (destructuring-bind (lambda-list (&rest store-variables) &body body) rest - (let ((whole-var (gensym "WHOLE-")) - (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) - whole-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 (,whole-var) - ,@local-decs + (lambda (,access-form ,environment) + ,@local-decs + (%defsetf ,access-form ,(length store-variables) + (lambda (,whole) ,body))) nil ',doc)))))) @@ -590,12 +599,18 @@ GET-SETF-EXPANSION directly." ,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))