[parenscript-devel] ps-loop now allows accumulating "into"

[Daniel Gackle]

I've extended PS-LOOP to allow CL-style explicit accumulation variables to
be introduced by INTO. Two examples, followed by a patch, are below.  (Side
note: Lisp still surprises me from time to time. That this feature could be
added with a net increase of only 3 lines of code is an indication of
something.)

Daniel

(ps (loop for x from 1 to 10
       sum x into total
       finally (alert total)))

=>

"var total = 0;
for (var x = 1; x <= 10; x += 1) {
    total += x;
};
alert(total);"

(ps (loop for x from 1 to 10
       for y = (foo x)
       collect y into z collect x into z
       sum x into w sum y into w))

=>

"var z = [];
var w = 0;
for (var x = 1, y = foo(x); x <= 10; x += 1, y = foo(x)) {
    z.push(y);
    z.push(x);
    w += x;
    w += y;
};"


>From 293fc20445cd44731c82a845401a8c897c851f6d Mon Sep 17 00:00:00 2001
From: Daniel Gackle <danielgackle at gmail.com>
Date: Tue, 30 Jun 2009 19:29:44 -0600
Subject: [PATCH] Extended PS-LOOP to allow explicit accumulation variables
(declared by INTO as in "sum x into y").

---
 src/lib/ps-loop.lisp |   37 ++++++++++++++++++++-----------------
 1 files changed, 20 insertions(+), 17 deletions(-)

diff --git a/src/lib/ps-loop.lisp b/src/lib/ps-loop.lisp
index 87d2d84..1003b5d 100644
--- a/src/lib/ps-loop.lisp
+++ b/src/lib/ps-loop.lisp
@@ -7,7 +7,7 @@

 (defvar *loop-keywords*
   '(:for :do :when :unless :initially :finally :first-time :last-time
:while :until
-    :from :to :below :downto :above :by :in :across :index := :then :sum
:collect))
+    :from :to :below :downto :above :by :in :across :index := :then :sum
:collect :into))

 (defun normalize-loop-keywords (args)
   (mapcar
@@ -22,7 +22,7 @@
         init-step-forms end-test-forms
         initially finally
         first-time last-time
-        accum-var accum-kind
+        default-accum-var default-accum-kind
         destructurings body)
     (macrolet ((with-local-var ((name expr) &body body)
                  (once-only (expr)
@@ -55,22 +55,25 @@
                  (when (next? term)
                    (consume)
                    (consume)))
-               (establish-accum-var (kind initial-val)
-                 (if accum-var
-                     (error "PS-LOOP encountered illegal ~a: a ~a was
previously declared, and there can only be one accumulation per loop." kind
accum-kind)
-                     (progn
-                       (setf accum-var (ps-gensym kind)
-                             accum-kind kind)
-                       (push `(var ,accum-var ,initial-val) prologue))))
+               (accumulate (kind term var)
+                 (when (null var)
+                   (when (and default-accum-kind (not (eq kind
default-accum-kind)))
+                     (error "PS-LOOP encountered illegal ~a: ~a was already
declared, and there can only be one kind of default accumulation per loop."
kind default-accum-kind))
+                   (unless default-accum-var
+                     (setf default-accum-var (ps-gensym kind)
+                           default-accum-kind kind))
+                   (setf var default-accum-var))
+                 (let ((initial (case kind (:sum 0) (:collect '(array)))))
+                   (pushnew `(var ,var ,initial) prologue :key #'second))
+                 (case kind
+                   (:sum `(incf ,var ,term))
+                   (:collect `((@ ,var :push) ,term))))
                (body-clause (term)
                  (case term
                    ((:when :unless) (list (intern (symbol-name term))
                                           (consume)
                                           (body-clause (consume-atom))))
-                   (:sum (establish-accum-var :sum 0)
-                         `(incf ,accum-var ,(consume)))
-                   (:collect (establish-accum-var :collect '(array))
-                     `((@ ,accum-var :push) ,(consume)))
+                   ((:sum :collect) (accumulate term (consume) (consume-if
:into)))
                    (:do (consume-progn))
                    (otherwise (err "a PS-LOOP keyword" term))))
                (for-from (var)
@@ -149,7 +152,7 @@
                 (nreverse finally)
                 (nreverse first-time)
                 (nreverse last-time)
-                accum-var
+                default-accum-var
                 (add-destructurings-to-body))))))

 (defpsmacro loop (&rest args)
@@ -157,12 +160,12 @@
                         init-step-forms end-test
                         initially finally
                         first-time last-time
-                        accum-var
+                        default-accum-var
                         body)
       (parse-ps-loop (normalize-loop-keywords args))
     (let ((first-guard (and first-time (ps-gensym)))
           (last-guard (and last-time (ps-gensym))))
-      `(,@(if accum-var '(with-lambda ()) '(progn))
+      `(,@(if default-accum-var '(with-lambda ()) '(progn))
           ,@(when first-time `((var ,first-guard t)))
           ,@(when last-time `((var ,last-guard nil)))
           , at prologue
@@ -178,4 +181,4 @@
                     `((setf ,last-guard t))))
           ,@(when last-time `((when ,last-guard , at last-time)))
           , at finally
-          ,@(when accum-var `((return ,accum-var)))))))
+          ,@(when default-accum-var `((return ,default-accum-var)))))))
-- 
1.6.1
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/parenscript-devel/attachments/20090630/934c2e5c/attachment.html>