From: Daniel Gackle <danielgackle@gmail.com>
Date: Tue, 18 Aug 2009 23:58:31 +0000 (-0700)
Subject: Correcting how parallel loop handles destructuring lists.
X-Git-Url: http://git.hcoop.net/clinton/parenscript.git/commitdiff_plain/da51b0e00892d23a322c4a5c6d5f153db8a59c19

Correcting how parallel loop handles destructuring lists.
---

diff --git a/src/lib/ps-loop.lisp b/src/lib/ps-loop.lisp
index f160f28..16436ad 100644
--- a/src/lib/ps-loop.lisp
+++ b/src/lib/ps-loop.lisp
@@ -232,23 +232,6 @@
             `((destructuring-bind ,it ,(first (car iterations)) ,@forms))
             forms))))
 
-(defun outer-body (loop)
-  (wrap-with-destructurings
-   (iterations loop)
-   (append (body loop)
-           (loop :for (var nil nil step test) :in (iterations loop)
-             :collect `(setf ,var ,step)
-             :when test :collect `(when ,test (break))))))
-
-(defun init-and-test (iterations form)
-  (loop :for (var nil init nil test) :in (reverse iterations) :do
-    (when test
-      (setf form `(unless ,test ,form)))
-    ;; (when bindings
-    ;;   (setf form `(destructuring-bind ,bindings ,var ,form)))
-    (setf form `(let ((,var ,init)) ,form)))
-  form)
-
 (defun loop-form-with-alternating-tests (loop)
   (let ((form `(progn
                  ,@(initially loop)
@@ -257,13 +240,26 @@
                             `((when ,(first-guard loop)
                                 ,@it
                                 (setf ,(first-guard loop) nil))))
-                   ,@(outer-body loop)
+                   ,@(body loop)
+                   ,@(loop :for (var bindings nil step test) :in (iterations loop)
+                       :collect `(setf ,var ,step)
+                       :collect `(dset ,bindings ,var)
+                       :when test :collect `(when ,test (break)))
                    ,@(when (during-last loop)
                            `((setf ,(last-guard loop) t))))
                  ,@(awhen (during-last loop)
                           `((when ,(last-guard loop) ,@it)))
                  ,@(finally loop))))
-    (init-and-test (iterations loop) form)))
+    ;; preface the whole thing with alternating inits and tests prior
+    ;; to the first pass through the loop. the goal is, like CL loop,
+    ;; to refrain from initializing subsequent clauses if a test fails
+    (loop :for (var bindings init nil test) :in (reverse (iterations loop)) :do
+      (when test
+        (setf form `(unless ,test ,form)))
+      (when bindings
+        (setf form `(destructuring-bind ,bindings ,var ,form)))
+      (setf form `(let ((,var ,init)) ,form)))
+    form))
 
 (defun simple-for-form (loop)
   `(progn
diff --git a/src/lib/ps-macro-lib.lisp b/src/lib/ps-macro-lib.lisp
index f505fc3..be90b79 100644
--- a/src/lib/ps-macro-lib.lisp
+++ b/src/lib/ps-macro-lib.lisp
@@ -144,7 +144,7 @@
                      (first args))))
     `((@ ,fn apply) this ,arglist)))
 
-(defun destructuring-wrap (arr n bindings body)
+(defun destructuring-wrap (arr n bindings body &key setf?)
   (cond ((null bindings)
          body)
         ((atom bindings)
@@ -153,13 +153,23 @@
                              ((@ ,arr slice) ,n))))
             ,body))
         (t (let ((var (car bindings))
-                 (inner-body (destructuring-wrap arr (1+ n) (cdr bindings) body)))
+                 (inner-body (destructuring-wrap arr (1+ n) (cdr bindings) body :setf? setf?)))
              (cond ((null var) inner-body)
-                   ((atom var) `(let ((,var (aref ,arr ,n)))
-                                  ,inner-body))
-                   (t `(destructuring-bind ,var (aref ,arr ,n)
+                   ((atom var) (if setf?
+                                   `(progn (setf ,var (aref ,arr ,n))
+                                           ,inner-body)
+                                   `(let ((,var (aref ,arr ,n)))
+                                      ,inner-body)))
+                   (t `(,(if setf? 'dset 'destructuring-bind)
+                         ,var (aref ,arr ,n)
                          ,inner-body)))))))
 
+(defpsmacro dset (bindings expr &body body)
+  (let ((arr (if (complex-js-expr? expr) (ps-gensym) expr)))
+    `(progn
+       ,@(unless (eq arr expr) `((setf ,arr ,expr)))
+       ,(destructuring-wrap arr 0 bindings (cons 'progn body) :setf? t))))
+
 (defpsmacro destructuring-bind (bindings expr &body body)
   (let* ((arr (if (complex-js-expr? expr) (ps-gensym) expr))
          (bound (destructuring-wrap arr 0 bindings (cons 'progn body))))