X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-setf.lisp;h=e829b6a5a70025200053c2cf3fc57e1494e7ca98;hb=b36697e233ff1ef1cc3ad2e687581520656d4755;hp=4ee0528164ab343dce74e2d92e230b78422c0330;hpb=b0b168c08b31a748150f404398af754f26fd4813;p=sbcl.git diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp index 4ee0528..e829b6a 100644 --- a/src/code/early-setf.lisp +++ b/src/code/early-setf.lisp @@ -85,13 +85,14 @@ GET-SETF-EXPANSION directly." (sb!xc:get-setf-expansion form environment) (when (cdr store-vars) (error "GET-SETF-METHOD used for a form with multiple store ~ - variables:~% ~S" + variables:~% ~S" form)) (values temps value-forms store-vars store-form access-form))) ;;; 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) @@ -164,76 +165,82 @@ 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) + (get-setf-method place env) + (let ((g (gensym))) + `(let* ((,g ,obj) + ,@(mapcar #'list dummies vals) + (,(car newval) (cons ,g ,getter))) + ,setter)))) (defmacro-mundanely pushnew (obj place &rest keys &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." + (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) (adjoin ,g ,getter ,@keys))) + ,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) + (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)))) (defmacro-mundanely remf (place indicator &environment env) #!+sb-doc @@ -250,8 +257,9 @@ GET-SETF-EXPANSION directly." (local1 (gensym)) (local2 (gensym))) ((null d) - (push (list (car newval) getter) let-list) + ;; See ANSI 5.1.3 for why we do out-of-order evaluation (push (list ind-temp indicator) let-list) + (push (list (car newval) getter) let-list) `(let* ,(nreverse let-list) (do ((,local1 ,(car newval) (cddr ,local1)) (,local2 nil ,local1)) @@ -266,6 +274,31 @@ GET-SETF-EXPANSION directly." ,setter (return t)))))))) (push (list (car d) (car v)) let-list)))) + +;;; 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) + (get-setf-method place env) + (let ((d (gensym))) + `(let* (,@(mapcar #'list dummies vals) + (,d ,delta) + (,(car newval) (+ ,getter ,d))) + ,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) + (get-setf-method place env) + (let ((d (gensym))) + `(let* (,@(mapcar #'list dummies vals) + (,d ,delta) + (,(car newval) (- ,getter ,d))) + ,setter)))) ;;;; DEFINE-MODIFY-MACRO stuff @@ -314,26 +347,18 @@ GET-SETF-EXPANSION directly." 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.") ;;;; 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) + (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" + treated as a function" name `(setf ,name))) ((not (fboundp `(setf ,name))) @@ -383,14 +408,14 @@ GET-SETF-EXPANSION directly." (%defsetf ,access-form-var ,(length store-variables) (lambda (,arglist-var) ,@local-decs - (block ,access-fn - ,body)))) + ,body))) 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 @@ -419,13 +444,12 @@ GET-SETF-EXPANSION directly." ;;; 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 @@ -434,7 +458,7 @@ GET-SETF-EXPANSION directly." (assign-setf-macro ',access-fn (lambda (,whole ,environment) ,@local-decs - (block ,access-fn ,body)) + ,body) nil ',doc))))) @@ -568,10 +592,10 @@ GET-SETF-EXPANSION directly." (sb!xc:define-setf-expander the (type place &environment 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))))