From 2100b87b090527861690b5a97119fed89f78c59c Mon Sep 17 00:00:00 2001
From: Daniel Gackle <danielgackle@gmail.com>
Date: Thu, 13 Aug 2009 13:04:19 -0700
Subject: [PATCH] Broke up loop parsing by pushing local functions to top level
 and passing a state object around.

---
 src/lib/ps-loop.lisp | 447 ++++++++++++++++++++++---------------------
 1 file changed, 232 insertions(+), 215 deletions(-)
 rewrite src/lib/ps-loop.lisp (91%)

diff --git a/src/lib/ps-loop.lisp b/src/lib/ps-loop.lisp
dissimilarity index 91%
index 2dd5ef7..00befcd 100644
--- a/src/lib/ps-loop.lisp
+++ b/src/lib/ps-loop.lisp
@@ -1,215 +1,232 @@
-(in-package :parenscript)
-
-(defun complex-js-expr? (expr)
-  (if (symbolp 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 :on :index := :then :sum :collect
-    :count :minimize :maximize :into :repeat))
-
-(defun normalize-loop-keywords (args)
-  (mapcar
-   (lambda (x)
-     (or (find-if (lambda (key) (and (symbolp x) (equal (symbol-name x) (symbol-name key))))
-                  *loop-keywords*)
-         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
-        initially finally
-        first-time last-time
-        default-accum-var default-accum-kind
-        destructurings body)
-    (macrolet ((with-local-var ((name expr) &body body)
-                 (once-only (expr)
-                   `(let ((,name (aif (and (complex-js-expr? ,expr) (ps-gensym))
-                                      (progn (push (list 'var it ,expr) prologue)
-                                             it)
-                                      ,expr)))
-                      ,@body))))
-      (labels ((next ()
-                 (car terms))
-               (next? (term)
-                 (eq (next) term))
-               (err (expected got)
-                 (error "PS-LOOP expected ~a, got ~a." expected got))
-               (consume (&optional what)
-                 (let ((term (pop terms)))
-                   (when (and what (not (eq what term)))
-                     (err what term))
-                   term))
-               (consume-atom ()
-                 (if (atom (next))
-                     (consume)
-                     (err "an atom" (next))))
-               (consume-progn ()
-                 (cons 'progn (loop :collect (if (consp (next))
-                                                 (consume)
-                                                 (err "a compound form" (next)))
-                                :until (atom (next)))))
-               (consume-if (term)
-                 (when (next? term)
-                   (consume)
-                   (consume)))
-               (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 (case kind
-                                                          (:minimize 'min)
-                                                          (:maximize 'max)
-                                                          (t kind)))
-                           default-accum-kind kind))
-                   (setf var default-accum-var))
-                 (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 `(unless (null ,term) (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 :count :minimize :maximize) (accumulate term (consume) (consume-if :into)))
-                   (:do (consume-progn))
-                   (otherwise (err "a PS-LOOP keyword" term))))
-               (for-from (var)
-                 (let ((start (consume))
-                       (op '+)
-                       (test nil)
-                       (by nil)
-                       (end nil))
-                   (loop while (member (next) '(:to :below :downto :above :by)) do
-                         (let ((term (consume)))
-                           (if (eq term :by)
-                               (setf by (consume))
-                               (setf op (case term ((:downto :above) '-) (otherwise '+))
-                                     test (case term (:to '>) (:below '>=) (:downto '<) (:above '<=))
-                                     end (consume)))))
-                   (push `(,var ,start (,op ,var ,(or by 1))) init-step-forms)
-                   (when test
-                     (with-local-var (end-var end)
-                       (push (list test var end-var) end-test-forms)))))
-               (for-= (var)
-                 (let ((start (consume))
-                       (then (consume-if :then)))
-                   (push (list var start (or then start)) init-step-forms)))
-               (for-in (var)
-                 (with-local-var (arr (consume))
-                   (let* ((index (or (consume-if :index) (ps-gensym)))
-                          (equiv `(:for ,index :from 0 :below (length ,arr)
-                                        :for ,var := (aref ,arr ,index))))
-                     (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))
-                        (varlist (unless var place))
-                        (term (consume-atom)))
-                   (when varlist
-                     (when (eq term :from)
-                       (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)))))
-               (repeat-clause ()
-                 (let ((index (ps-gensym)))
-                   (setf terms (append `(:for ,index :from 0 :below ,(consume)) terms))
-                   (clause)))
-               (clause ()
-                 (let ((term (consume-atom)))
-                   (case term
-                     (:for (for-clause))
-                     (:repeat (repeat-clause))
-                     (:while (push `(unless ,(consume) break) body))
-                     (:until (push `(when ,(consume) break) body))
-                     (:initially (push (consume-progn) initially))
-                     (:finally (push (consume-progn) finally))
-                     (:first-time (push (consume-progn) first-time))
-                     (:last-time (push (consume-progn) last-time))
-                     (otherwise (push (body-clause term) body))))))
-        (if terms
-            (loop :while terms :do (clause))
-            (err "loop definition" nil)))
-      (flet ((end-test ()
-               (aif (nreverse end-test-forms)
-                    (if (cdr it)
-                        (list (cons 'or it))
-                        it)
-                    (list nil)))
-             (add-destructurings-to-body ()
-               (setf body (nreverse body))
-               (loop :for (list var) :in destructurings :do
-                 (setf body `((destructuring-bind ,list ,var ,@body))))
-               body))
-        (values (nreverse prologue)
-                (nreverse init-step-forms)
-                (end-test)
-                (nreverse initially)
-                (nreverse finally)
-                (nreverse first-time)
-                (nreverse last-time)
-                default-accum-var
-                (add-destructurings-to-body))))))
-
-(defpsmacro loop (&rest args)
-  (multiple-value-bind (prologue
-                        init-step-forms end-test
-                        initially finally
-                        first-time last-time
-                        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 default-accum-var '(with-lambda ()) '(progn))
-          ,@(when first-time `((var ,first-guard t)))
-          ,@(when last-time `((var ,last-guard nil)))
-          ,@prologue
-          ,@initially
-          (do* ,init-step-forms
-               ,end-test
-            ,@(when first-time
-                    `((when ,first-guard
-                        ,@first-time
-                        (setf ,first-guard nil))))
-            ,@body
-            ,@(when last-time
-                    `((setf ,last-guard t))))
-          ,@(when last-time `((when ,last-guard ,@last-time)))
-          ,@finally
-          ,@(when default-accum-var `((return ,default-accum-var)))))))
+(in-package :parenscript)
+
+(defun complex-js-expr? (expr)
+  (if (symbolp 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 :on :index := :then :sum :collect
+    :count :minimize :maximize :into :repeat))
+
+(defun normalize-loop-keywords (args)
+  (mapcar
+   (lambda (x)
+     (or (find-if (lambda (key) (and (symbolp x) (equal (symbol-name x) (symbol-name key))))
+                  *loop-keywords*)
+         x))
+   args))
+
+(defun reduce-function-symbol (sym)
+  (if (and (consp sym) (eq 'function (first sym)))
+      (second sym)
+      sym))
+
+(defun err (expected got)
+  (error "PS-LOOP expected ~a, got ~a." expected got))
+
+(defclass loop-state ()
+  ((tokens :initarg :tokens :accessor tokens)
+   (iterations :initform nil :accessor iterations)
+   (prologue :initform nil :accessor prologue)
+   (destructurings :initform nil :accessor destructurings)
+   (initially :initform nil :accessor initially)
+   (finally :initform nil :accessor finally)
+   (during-first :initform nil :accessor during-first)
+   (during-last :initform nil :accessor during-last)
+   (default-accum-var :initform nil :accessor default-accum-var)
+   (default-accum-kind :initform nil :accessor default-accum-kind)
+   (body :initform nil :accessor body)))
+
+(defun nreverse-loop-state (state)
+  (macrolet ((rev% (&rest accs)
+               (cons 'progn (loop :for a :in accs :collect `(setf (,a state) (nreverse (,a state)))))))
+    (rev% iterations prologue initially finally during-first during-last)
+    (let ((body (nreverse (body state))))
+      (loop :for (list var) :in (destructurings state) :do
+        (setf body `((destructuring-bind ,list ,var ,@body))))
+      (setf (body state) body)))
+  state)
+
+(defun push-tokens (state toks)
+  (setf (tokens state) (append toks (tokens state))))
+
+(defun peek (state)
+  (car (tokens state)))
+
+(defun eat (state &optional what tag)
+  (case what
+    (:if (when (eq (peek state) tag)
+           (eat state)
+           (eat state)))
+    (:progn (cons 'progn (loop :collect (if (consp (peek state))
+                                            (eat state)
+                                            (err "a compound form" (peek state)))
+                           :until (atom (peek state)))))
+    (otherwise (let ((tok (pop (tokens state))))
+                 (when (and (eq what :atom) (not (atom tok)))
+                   (err "an atom" tok))
+                 tok))))
+
+(defmacro with-local-var ((name expr state) &body body)
+  (once-only (expr)
+    `(let ((,name (aif (and (complex-js-expr? ,expr) (ps-gensym))
+                       (progn (push (list 'var it ,expr) (prologue ,state))
+                              it)
+                       ,expr)))
+       ,@body)))
+
+(defun for-from (var state)
+  (let ((start (eat state))
+        (op '+)
+        (test-op nil)
+        (by nil)
+        (end nil))
+    (loop while (member (peek state) '(:to :below :downto :above :by)) do
+          (let ((term (eat state)))
+            (if (eq term :by)
+                (setf by (eat state))
+                (setf op (case term ((:downto :above) '-) (otherwise '+))
+                      test-op (case term (:to '>) (:below '>=) (:downto '<) (:above '<=))
+                      end (eat state)))))
+    (let ((test (when test-op
+                  (with-local-var (v end state)
+                    (list test-op var v)))))
+      (push `(,var ,start (,op ,var ,(or by 1)) ,test) (iterations state)))))
+
+(defun for-= (var state)
+  (let ((start (eat state))
+        (then (eat state :if :then)))
+    (push (list var start (or then start) nil) (iterations state))))
+
+(defun for-in (var state)
+  (with-local-var (arr (eat state) state)
+    (let ((index (or (eat state :if :index) (ps-gensym))))
+      (push-tokens state `(,index :from 0 :below (length ,arr)
+                                  ,var := (aref ,arr ,index)))
+      (for-clause state)
+      (for-clause state))))
+
+(defun for-on (var state)
+  (with-local-var (arr (eat state) state)
+    (let ((by (aif (eat state :if :by)
+                   `(,(reduce-function-symbol it) ,var)
+                   `((@ ,var :slice) 1))))
+      (push-tokens state `(,var := ,arr :then ,by))
+      (for-clause state)
+      ;; set the end-test
+      (setf (fourth (car (iterations state))) `(or (null ,var) (= (length ,var) 0))))))
+
+(defun for-clause (state)
+  (let* ((place (eat state))
+         (var (when (atom place) place))
+         (varlist (unless var place))
+         (term (eat state :atom)))
+    (when varlist
+      (when (eq term :from)
+        (err "an atom after FROM" varlist))
+      (setf var (ps-gensym))
+      (push (list varlist var) (destructurings state)))
+    (case term
+      (:from (for-from var state))
+      (:= (for-= var state))
+      ((:in :across) (for-in var state))
+      (:on (for-on var state))
+      (otherwise (error "FOR ~s ~s is not valid in PS-LOOP." var term)))))
+
+(defun accumulate (kind term var state)
+  (when (null var)
+    (when (and (default-accum-kind state) (not (eq kind (default-accum-kind state))))
+      (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 state)))
+    (unless (default-accum-var state)
+      (setf (default-accum-var state)
+            (ps-gensym (case kind
+                         (:minimize 'min)
+                         (:maximize 'max)
+                         (t kind))))
+      (setf (default-accum-kind state) kind))
+    (setf var (default-accum-var state)))
+  (let ((initial (case kind
+                   ((:sum :count) 0)
+                   ((:maximize :minimize) nil)
+                   (:collect '(array)))))
+    (pushnew `(var ,var ,initial) (prologue state) :key #'second))
+  (case kind
+    (:sum `(incf ,var ,term))
+    (:count `(unless (null ,term) (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))))
+
+(defun repeat-clause (state)
+  (let ((index (ps-gensym)))
+    (setf (tokens state) (append `(,index :from 0 :below ,(eat state)) (tokens state)))
+    (for-clause state)))
+
+(defun body-clause (term state)
+  (case term
+    ((:when :unless) (list (intern (symbol-name term))
+                           (eat state)
+                           (body-clause (eat state :atom) state)))
+    ((:sum :collect :count :minimize :maximize) (accumulate term (eat state) (eat state :if :into) state))
+    (:do (eat state :progn))
+    (otherwise (err "a PS-LOOP keyword" term))))
+
+(defun clause (state)
+  (let ((term (eat state :atom)))
+    (case term
+      (:for (for-clause state))
+      (:repeat (repeat-clause state))
+      (:while (push `(unless ,(eat state) break) (body state)))
+      (:until (push `(when ,(eat state) break) (body state)))
+      (:initially (push (eat state :progn) (initially state)))
+      (:finally (push (eat state :progn) (finally state)))
+      (:first-time (push (eat state :progn) (during-first state)))
+      (:last-time (push (eat state :progn) (during-last state)))
+      (otherwise (push (body-clause term state) (body state))))))
+
+(defun parse-ps-loop (terms)
+  (if (null terms)
+      (err "loop definition" nil)
+      (let ((state (make-instance 'loop-state :tokens terms)))
+        (loop :while (tokens state) :do (clause state))
+        (nreverse-loop-state state))))
+
+(defun init-forms (loop)
+  (mapcar (lambda (x) (subseq x 0 2)) (iterations loop)))
+
+(defun step-forms (loop)
+  (mapcar (lambda (x) `(setf ,(first x) ,(third x))) (iterations loop)))
+
+(defun end-test (loop)
+  (aif (loop :for (nil nil nil test) :in (iterations loop) :when test :collect test)
+       (if (cdr it)
+           (list 'not (cons 'or it))
+           (cons 'not it))
+       '(not nil)))
+
+(defpsmacro loop (&rest args)
+  (let* ((loop (parse-ps-loop (normalize-loop-keywords args)))
+         (first-guard (and (during-first loop) (ps-gensym)))
+         (last-guard (and (during-last loop) (ps-gensym))))
+    `(,@(if (default-accum-var loop) '(with-lambda ()) '(progn))
+        ,@(when (during-first loop) `((var ,first-guard t)))
+        ,@(when (during-last loop) `((var ,last-guard nil)))
+        ,@(prologue loop)
+        ,@(initially loop)
+        (for ,(init-forms loop)
+          (,(end-test loop))
+          ,(step-forms loop)
+          ,@(when (during-first loop)
+                  `((when ,first-guard
+                      ,@(during-first loop)
+                      (setf ,first-guard nil))))
+          ,@(body loop)
+          ,@(when (during-last loop)
+                  `((setf ,last-guard t))))
+        ,@(when (during-last loop)
+                `((when ,last-guard ,@(during-last loop))))
+        ,@(finally loop)
+        ,@(when (default-accum-var loop) `((return ,(default-accum-var loop)))))))
-- 
2.20.1