[parenscript-devel] Added count, minimize, and maximize to ps-loop

[Daniel Gackle]

I've added count, minimize, and maximize to ps-loop. Examples and patch
follow.

Daniel

(ps (loop for x from 1 to 10 count x into c))

=>

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

(ps (loop for x from 1 to 10 minimize x into y maximize x into z))

=>

"var y = null;
var z = null;
for (var x = 1; x <= 10; x += 1) {
    y = y == null ? x : Math.min(y, x);
    z = z == null ? x : Math.max(z, x);
};"


>From ee44a1647b9289c50c5fe1f2bc62c569aa0c990e Mon Sep 17 00:00:00 2001
From: Daniel Gackle <danielgackle at gmail.com>
Date: Tue, 30 Jun 2009 19:52:12 -0600
Subject: [PATCH] Added support for COUNT, MINIMIZE and MAXIMIZE to PS-LOOP.

---
 src/lib/ps-loop.lisp |   18 ++++++++++++++----
 1 files changed, 14 insertions(+), 4 deletions(-)

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

 (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 :into))
+    :from :to :below :downto :above :by :in :across :index := :then :sum
:collect
+    :count :minimize :maximize :into))

 (defun normalize-loop-keywords (args)
   (mapcar
@@ -60,20 +61,29 @@
                    (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)
+                     (setf default-accum-var (ps-gensym (case kind
+                                                          (:minimize 'min)
+                                                          (:maximize 'max)
+                                                          (t kind)))
                            default-accum-kind kind))
                    (setf var default-accum-var))
-                 (let ((initial (case kind (:sum 0) (:collect '(array)))))
+                 (let ((initial (case kind
+                                  ((:sum :count) 0)
+                                  ((:maximize :minimize) nil)
+                                  (:collect '(array)))))
                    (pushnew `(var ,var ,initial) prologue :key #'second))
                  (case kind
                    (:sum `(incf ,var ,term))
+                   (:count `(incf ,var))
+                   (:minimize `(setf ,var (if (null ,var) ,term (min ,var
,term))))
+                   (:maximize `(setf ,var (if (null ,var) ,term (max ,var
,term))))
                    (:collect `((@ ,var :push) ,term))))
                (body-clause (term)
                  (case term
                    ((:when :unless) (list (intern (symbol-name term))
                                           (consume)
                                           (body-clause (consume-atom))))
-                   ((:sum :collect) (accumulate term (consume) (consume-if
:into)))
+                   ((:sum :collect :count :minimize :maximize) (accumulate
term (consume) (consume-if :into)))
                    (:do (consume-progn))
                    (otherwise (err "a PS-LOOP keyword" term))))
                (for-from (var)
-- 
1.6.1
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/parenscript-devel/attachments/20090630/00f89c86/attachment.html>