Skip to content
Snippets Groups Projects
Commit 0d7a4c95 authored by pw's avatar pw
Browse files

New shiftf from Bruno Haible fixes problem with duplicated places.

parent d755099f
Branches
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -726,38 +726,27 @@
`(progn ,@(setters) nil)))) `(progn ,@(setters) nil))))
(thunk (let*-bindings) (mv-bindings))))) (thunk (let*-bindings) (mv-bindings)))))
(defmacro shiftf (&whole form &rest args &environment env)
(defmacro shiftf (&rest args &environment env)
"One or more SETF-style place expressions, followed by a single "One or more SETF-style place expressions, followed by a single
value expression. Evaluates all of the expressions in turn, then value expression. Evaluates all of the expressions in turn, then
assigns the value of each expression to the place on its left, assigns the value of each expression to the place on its left,
returning the value of the leftmost." returning the value of the leftmost."
(if (< (length args) 2) (when (< (length args) 2)
(error "Too few argument forms to a SHIFTF.")) (error "~S called with too few arguments: ~S" 'shiftf form))
(collect ((let*-bindings) (forms)) (let ((resultvar (gensym)))
(do ((first t nil) (do ((arglist args (cdr arglist))
(a args (cdr a)) (bindlist nil)
(prev-store-vars) (storelist nil)
(prev-setter)) (lastvar resultvar))
((endp (cdr a)) ((atom (cdr arglist))
(forms `(multiple-value-bind ,prev-store-vars ,(car a) (push `(,lastvar ,(first arglist)) bindlist)
,prev-setter))) `(LET* ,(nreverse bindlist) ,@(nreverse storelist) ,resultvar))
(multiple-value-bind (multiple-value-bind (SM1 SM2 SM3 SM4 SM5)
(temps exprs store-vars setter getter) (get-setf-method (first arglist) env)
(get-setf-expansion (car a) env) (mapc #'(lambda (var val) (push `(,var ,val) bindlist)) SM1 SM2)
(loop (push `(,lastvar ,SM5) bindlist)
for temp in temps (push SM4 storelist)
for expr in exprs (setq lastvar (first SM3))))))
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)))))
(defmacro rotatef (&rest args &environment env) (defmacro rotatef (&rest args &environment env)
"Takes any number of SETF-style place expressions. Evaluates all of the "Takes any number of SETF-style place expressions. Evaluates all of the
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment