From 70c34384f0cfaa33f9eb93fd597d7a50f4434fdf Mon Sep 17 00:00:00 2001
From: Daniel Gackle <danielgackle@gmail.com>
Date: Fri, 10 Jul 2009 19:17:39 -0600
Subject: [PATCH] PS LOOP now supports ON.

---
 src/lib/ps-loop.lisp | 22 +++++++++++++++++++---
 1 file changed, 19 insertions(+), 3 deletions(-)

diff --git a/src/lib/ps-loop.lisp b/src/lib/ps-loop.lisp
index 0e20c9c..c7334fa 100644
--- a/src/lib/ps-loop.lisp
+++ b/src/lib/ps-loop.lisp
@@ -2,12 +2,13 @@
 
 (defun complex-js-expr? (expr)
   (if (symbolp expr)
-      (find #\. (symbol-name expr))
+      (or (find #\. (symbol-name expr))
+          (not (eq (ps-macroexpand expr) expr)))
       (consp expr)))
 
 (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 :on :index := :then :sum :collect
     :count :minimize :maximize :into))
 
 (defun normalize-loop-keywords (args)
@@ -18,6 +19,11 @@
          x))
    args))
 
+(defun reduce-function-symbol (sym)
+  (if (and (consp sym) (eq 'function (first sym)))
+      (second sym)
+      sym))
+
 (defun parse-ps-loop (terms)
   (let (prologue
         init-step-forms end-test-forms
@@ -115,6 +121,15 @@
                      (setf terms (append equiv terms))
                      (clause)
                      (clause))))
+               (for-on (var)
+                 (with-local-var (arr (consume))
+                   (push `(or (null ,var) (= (length ,var) 0)) end-test-forms)
+                   (let* ((by (aif (consume-if :by)
+                                   `(,(reduce-function-symbol it) ,var)
+                                   `((@ ,var :slice) 1)))
+                          (equiv `(:for ,var := ,arr :then ,by)))
+                     (setf terms (append equiv terms))
+                     (clause))))
                (for-clause ()
                  (let* ((place (consume))
                         (var (when (atom place) place))
@@ -122,13 +137,14 @@
                         (term (consume-atom)))
                    (when varlist
                      (when (eq term :from)
-                       (err "an atom after FROM" varlist))
+                       (err "an atom after FOR" varlist))
                      (setf var (ps-gensym))
                      (push (list varlist var) destructurings))
                    (case term
                      (:from (for-from var))
                      (:= (for-= var))
                      ((:in :across) (for-in var))
+                     (:on (for-on var))
                      (otherwise (error "FOR ~s ~s is not valid in PS-LOOP." var term)))))
                (clause ()
                  (let ((term (consume-atom)))
-- 
2.20.1