From: Christophe R. <cr...@us...> - 2002-11-21 15:55:47
|
Update of /cvsroot/sbcl/sbcl/src/code In directory sc8-pr-cvs1:/tmp/cvs-serv24592/src/code Modified Files: loop.lisp Log Message: 0.7.9.61: Fix destructuring of LOOP WITH <x> where <x> is a tree with NIL in it. ... define and use a somewhat KLUDGEy LOOP-DESTRUCTURING-BIND. Index: loop.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/loop.lisp,v retrieving revision 1.25 retrieving revision 1.26 diff -u -d -r1.25 -r1.26 --- loop.lisp 20 Nov 2002 15:40:36 -0000 1.25 +++ loop.lisp 21 Nov 2002 15:55:44 -0000 1.26 @@ -760,9 +760,27 @@ specified-type required-type))) specified-type))) +(defun subst-gensyms-for-nil (tree) + (declare (special *ignores*)) + (cond + ((null tree) (car (push (gensym "LOOP-IGNORED-VAR-") *ignores*))) + ((atom tree) tree) + (t (cons (subst-gensyms-for-nil (car tree)) + (subst-gensyms-for-nil (cdr tree)))))) + +(sb!int:defmacro-mundanely loop-destructuring-bind + (lambda-list arg-list &rest body) + (let ((*ignores* nil)) + (declare (special *ignores*)) + (let ((d-var-lambda-list (subst-gensyms-for-nil lambda-list))) + `(destructuring-bind ,d-var-lambda-list + ,arg-list + (declare (ignore ,@*ignores*)) + ,@body)))) + (defun loop-build-destructuring-bindings (crocks forms) (if crocks - `((destructuring-bind ,(car crocks) ,(cadr crocks) + `((loop-destructuring-bind ,(car crocks) ,(cadr crocks) ,@(loop-build-destructuring-bindings (cddr crocks) forms))) forms)) |