<span style="font-family: arial,helvetica,sans-serif;">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.)<br>
<br>Daniel<br style="font-family: courier new,monospace;"></span><br style="font-family: courier new,monospace;">
<span style="font-family: courier new,monospace;">(ps (loop for x from 1 to 10 <br> sum x into total <br> finally (alert total)))</span><br><br>=><br><br style="font-family: courier new,monospace;"><span style="font-family: courier new,monospace;">"var total = 0;</span><br style="font-family: courier new,monospace;">
<span style="font-family: courier new,monospace;">for (var x = 1; x <= 10; x += 1) {</span><br style="font-family: courier new,monospace;"><span style="font-family: courier new,monospace;"> total += x;</span><br style="font-family: courier new,monospace;">
<span style="font-family: courier new,monospace;">};</span><br style="font-family: courier new,monospace;"><span style="font-family: courier new,monospace;">alert(total);"</span><br><br><span style="font-family: courier new,monospace;">(ps (loop for x from 1 to 10 <br>
for y = (foo x) <br> collect y into z collect x into z <br> sum x into w sum y into w))</span><br style="font-family: courier new,monospace;"><br style="font-family: courier new,monospace;"><span style="font-family: courier new,monospace;">=></span><br style="font-family: courier new,monospace;">
<br style="font-family: courier new,monospace;"><span style="font-family: courier new,monospace;">
"var z = [];</span><br style="font-family: courier new,monospace;"><span style="font-family: courier new,monospace;">var w = 0;</span><br style="font-family: courier new,monospace;"><span style="font-family: courier new,monospace;">for (var x = 1, y = foo(x); x <= 10; x += 1, y = foo(x)) {</span><br style="font-family: courier new,monospace;">
<span style="font-family: courier new,monospace;"> z.push(y);</span><br style="font-family: courier new,monospace;"><span style="font-family: courier new,monospace;"> z.push(x);</span><br style="font-family: courier new,monospace;">
<span style="font-family: courier new,monospace;"> w += x;</span><br style="font-family: courier new,monospace;"><span style="font-family: courier new,monospace;"> w += y;</span><br style="font-family: courier new,monospace;">
<span style="font-family: courier new,monospace;">};"</span><br><br><br>From 293fc20445cd44731c82a845401a8c897c851f6d Mon Sep 17 00:00:00 2001<br>From: Daniel Gackle <<a href="mailto:danielgackle@gmail.com">danielgackle@gmail.com</a>><br>
Date: Tue, 30 Jun 2009 19:29:44 -0600<br>Subject: [PATCH] Extended PS-LOOP to allow explicit accumulation variables (declared by INTO as in "sum x into y").<br><br>---<br> src/lib/ps-loop.lisp | 37 ++++++++++++++++++++-----------------<br>
1 files changed, 20 insertions(+), 17 deletions(-)<br><br>diff --git a/src/lib/ps-loop.lisp b/src/lib/ps-loop.lisp<br>index 87d2d84..1003b5d 100644<br>--- a/src/lib/ps-loop.lisp<br>+++ b/src/lib/ps-loop.lisp<br>@@ -7,7 +7,7 @@<br>
<br> (defvar *loop-keywords*<br> '(:for :do :when :unless :initially :finally :first-time :last-time :while :until<br>- :from :to :below :downto :above :by :in :across :index := :then :sum :collect))<br>+ :from :to :below :downto :above :by :in :across :index := :then :sum :collect :into))<br>
<br> (defun normalize-loop-keywords (args)<br> (mapcar<br>@@ -22,7 +22,7 @@<br> init-step-forms end-test-forms<br> initially finally<br> first-time last-time<br>- accum-var accum-kind<br>
+ default-accum-var default-accum-kind<br> destructurings body)<br> (macrolet ((with-local-var ((name expr) &body body)<br> (once-only (expr)<br>@@ -55,22 +55,25 @@<br> (when (next? term)<br>
(consume)<br> (consume)))<br>- (establish-accum-var (kind initial-val)<br>- (if accum-var<br>- (error "PS-LOOP encountered illegal ~a: a ~a was previously declared, and there can only be one accumulation per loop." kind accum-kind)<br>
- (progn<br>- (setf accum-var (ps-gensym kind)<br>- accum-kind kind)<br>- (push `(var ,accum-var ,initial-val) prologue))))<br>+ (accumulate (kind term var)<br>
+ (when (null var)<br>+ (when (and default-accum-kind (not (eq kind default-accum-kind)))<br>+ (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))<br>
+ (unless default-accum-var<br>+ (setf default-accum-var (ps-gensym kind)<br>+ default-accum-kind kind))<br>+ (setf var default-accum-var))<br>
+ (let ((initial (case kind (:sum 0) (:collect '(array)))))<br>+ (pushnew `(var ,var ,initial) prologue :key #'second))<br>+ (case kind<br>+ (:sum `(incf ,var ,term))<br>
+ (:collect `((@ ,var :push) ,term))))<br> (body-clause (term)<br> (case term<br> ((:when :unless) (list (intern (symbol-name term))<br> (consume)<br>
(body-clause (consume-atom))))<br>- (:sum (establish-accum-var :sum 0)<br>- `(incf ,accum-var ,(consume)))<br>- (:collect (establish-accum-var :collect '(array))<br>
- `((@ ,accum-var :push) ,(consume)))<br>+ ((:sum :collect) (accumulate term (consume) (consume-if :into)))<br> (:do (consume-progn))<br> (otherwise (err "a PS-LOOP keyword" term))))<br>
(for-from (var)<br>@@ -149,7 +152,7 @@<br> (nreverse finally)<br> (nreverse first-time)<br> (nreverse last-time)<br>- accum-var<br>+ default-accum-var<br>
(add-destructurings-to-body))))))<br> <br> (defpsmacro loop (&rest args)<br>@@ -157,12 +160,12 @@<br> init-step-forms end-test<br> initially finally<br>
first-time last-time<br>- accum-var<br>+ default-accum-var<br> body)<br> (parse-ps-loop (normalize-loop-keywords args))<br>
(let ((first-guard (and first-time (ps-gensym)))<br> (last-guard (and last-time (ps-gensym))))<br>- `(,@(if accum-var '(with-lambda ()) '(progn))<br>+ `(,@(if default-accum-var '(with-lambda ()) '(progn))<br>
,@(when first-time `((var ,first-guard t)))<br> ,@(when last-time `((var ,last-guard nil)))<br> ,@prologue<br>@@ -178,4 +181,4 @@<br> `((setf ,last-guard t))))<br> ,@(when last-time `((when ,last-guard ,@last-time)))<br>
,@finally<br>- ,@(when accum-var `((return ,accum-var)))))))<br>+ ,@(when default-accum-var `((return ,default-accum-var)))))))<br>-- <br>1.6.1<br><br><br style="font-family: courier new,monospace;">