diff --git a/code/macros.lisp b/code/macros.lisp index 852b04fe14560d9165b02adf226362327d9b76ab..cb87a18e8e6858462cb8e56380d599e0e5d6a645 100644 --- a/code/macros.lisp +++ b/code/macros.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.49 1997/05/08 20:52:43 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.50 1997/06/05 13:02:45 pw Exp $") ;;; ;;; ********************************************************************** ;;; @@ -726,38 +726,27 @@ `(progn ,@(setters) nil)))) (thunk (let*-bindings) (mv-bindings))))) - -(defmacro shiftf (&rest args &environment env) +(defmacro shiftf (&whole form &rest args &environment env) "One or more SETF-style place expressions, followed by a single value expression. Evaluates all of the expressions in turn, then assigns the value of each expression to the place on its left, returning the value of the leftmost." - (if (< (length args) 2) - (error "Too few argument forms to a SHIFTF.")) - (collect ((let*-bindings) (forms)) - (do ((first t nil) - (a args (cdr a)) - (prev-store-vars) - (prev-setter)) - ((endp (cdr a)) - (forms `(multiple-value-bind ,prev-store-vars ,(car a) - ,prev-setter))) - (multiple-value-bind - (temps exprs store-vars setter getter) - (get-setf-expansion (car a) env) - (loop - for temp in temps - for expr in exprs - do (let*-bindings `(,temp ,expr))) - (forms (if first - getter - `(multiple-value-bind ,prev-store-vars ,getter - ,prev-setter))) - (setf prev-store-vars store-vars) - (setf prev-setter setter))) - `(let* ,(let*-bindings) - (multiple-value-prog1 - ,@(forms))))) + (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)))))) (defmacro rotatef (&rest args &environment env) "Takes any number of SETF-style place expressions. Evaluates all of the