X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-setf.lisp;h=e829b6a5a70025200053c2cf3fc57e1494e7ca98;hb=380ea897e2c12a01547f918f73e8a1db0a3a0373;hp=e985443eb8bac8c8e120b758a895266d2c033878;hpb=667ec9d494530079bef28e8589dd0d3274b935ec;p=sbcl.git diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp index e985443..e829b6a 100644 --- a/src/code/early-setf.lisp +++ b/src/code/early-setf.lisp @@ -47,9 +47,9 @@ ;; Local functions inhibit global SETF methods. ((and environment (let ((name (car form))) - (dolist (x (sb!c::lexenv-functions environment)) + (dolist (x (sb!c::lexenv-funs environment)) (when (and (eq (car x) name) - (not (sb!c::defined-function-p (cdr x)))) + (not (sb!c::defined-fun-p (cdr x)))) (return t))))) (expand-or-get-setf-inverse form environment)) ((setq temp (info :setf :inverse (car form))) @@ -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) @@ -101,7 +102,7 @@ GET-SETF-EXPANSION directly." `(funcall #'(setf ,(car form))) t)))) -(defun get-setf-method-inverse (form inverse setf-function) +(defun get-setf-method-inverse (form inverse setf-fun) (let ((new-var (gensym)) (vars nil) (vals nil)) @@ -110,18 +111,19 @@ GET-SETF-EXPANSION directly." (push x vals)) (setq vals (nreverse vals)) (values vars vals (list new-var) - (if setf-function + (if setf-fun `(,@inverse ,new-var ,@vars) `(,@inverse ,@vars ,new-var)) `(,(car form) ,@vars)))) ;;;; 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 @@ -163,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 @@ -249,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)) @@ -265,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 @@ -313,36 +347,23 @@ 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))) ;; 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) - (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)))) @@ -382,19 +403,19 @@ GET-SETF-EXPANSION directly." `(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)))) + (lambda (,access-form-var ,env-var) + (declare (ignore ,env-var)) + (%defsetf ,access-form-var ,(length store-variables) + (lambda (,arglist-var) + ,@local-decs + ,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 @@ -423,22 +444,21 @@ 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 :environment environment) `(eval-when (:compile-toplevel :load-toplevel :execute) (assign-setf-macro ',access-fn - #'(lambda (,whole ,environment) - ,@local-decs - (block ,access-fn ,body)) + (lambda (,whole ,environment) + ,@local-decs + ,body) nil ',doc))))) @@ -572,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))))