X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-setf.lisp;h=3cddab43f5904ec4a489a441072a99400f9cfff7;hb=ba39d165a0bb6fabba6d6feb9b6fb88ae4d544ff;hp=8a21d7ae2097ba9569a225f263e931c2f27b04f0;hpb=f865612b20955e92189b1e683203e12c8f08eb79;p=sbcl.git diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp index 8a21d7a..3cddab4 100644 --- a/src/code/early-setf.lisp +++ b/src/code/early-setf.lisp @@ -37,83 +37,73 @@ 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-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)) - ((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))))) - -;;; 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)))) ;;;; SETF itself @@ -133,26 +123,26 @@ GET-SETF-EXPANSION directly." (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)))))) ;;;; various SETF-related macros @@ -164,76 +154,83 @@ GET-SETF-EXPANSION directly." 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 @@ -242,30 +239,54 @@ GET-SETF-EXPANSION directly." 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)))) ;;;; DEFINE-MODIFY-MACRO stuff @@ -273,76 +294,70 @@ GET-SETF-EXPANSION directly." #!+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)))))) ;;;; 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) + (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)) - ((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)) @@ -357,143 +372,148 @@ 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))) - `(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))))) ;;;; 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 @@ -506,16 +526,16 @@ GET-SETF-EXPANSION directly." ;;; 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) @@ -525,28 +545,29 @@ GET-SETF-EXPANSION directly." 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 @@ -555,23 +576,30 @@ GET-SETF-EXPANSION directly." 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))