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

[Vladimir Sedach]

Pushed. Thanks for the patches!

On Tue, Jun 30, 2009 at 7:39 PM, Daniel Gackle<danielgackle at gmail.com> wrote:
> 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
>
>
>
> _______________________________________________
> parenscript-devel mailing list
> parenscript-devel at common-lisp.net
> http://common-lisp.net/cgi-bin/mailman/listinfo/parenscript-devel
>
>