Made PS LOOP conform to LOOP's semantics regarding parallel FOR clauses. A clause...

diff --git a/src/lib/ps-loop.lisp b/src/lib/ps-loop.lisp
index 00befcd..80dffbc 100644 (file)
--- a/src/lib/ps-loop.lisp
+++ b/src/lib/ps-loop.lisp
@@ -35,7 +35,9 @@
    (initially :initform nil :accessor initially)
    (finally :initform nil :accessor finally)
    (during-first :initform nil :accessor during-first)
    (initially :initform nil :accessor initially)
    (finally :initform nil :accessor finally)
    (during-first :initform nil :accessor during-first)

+   (first-guard :initform nil :accessor first-guard)

    (during-last :initform nil :accessor during-last)
    (during-last :initform nil :accessor during-last)

+   (last-guard :initform nil :accessor last-guard)

    (default-accum-var :initform nil :accessor default-accum-var)
    (default-accum-kind :initform nil :accessor default-accum-kind)
    (body :initform nil :accessor body)))
    (default-accum-var :initform nil :accessor default-accum-var)
    (default-accum-kind :initform nil :accessor default-accum-kind)
    (body :initform nil :accessor body)))


@@ -160,6 +162,16 @@
     (:maximize `(setf ,var (if (null ,var) ,term (max ,var ,term))))
     (:collect `((@ ,var :push) ,term))))
 
     (:maximize `(setf ,var (if (null ,var) ,term (max ,var ,term))))
     (:collect `((@ ,var :push) ,term))))
 

+(defun first-time-clause (state)
+  (push (eat state :progn) (during-first state))
+  (unless (first-guard state)
+    (setf (first-guard state) (ps-gensym))))
+
+(defun last-time-clause (state)
+  (push (eat state :progn) (during-last state))
+  (unless (last-guard state)
+    (setf (last-guard state) (ps-gensym))))
+

 (defun repeat-clause (state)
   (let ((index (ps-gensym)))
     (setf (tokens state) (append `(,index :from 0 :below ,(eat state)) (tokens state)))
 (defun repeat-clause (state)
   (let ((index (ps-gensym)))
     (setf (tokens state) (append `(,index :from 0 :below ,(eat state)) (tokens state)))


@@ -183,8 +195,8 @@
       (:until (push `(when ,(eat state) break) (body state)))
       (:initially (push (eat state :progn) (initially state)))
       (:finally (push (eat state :progn) (finally 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)))
+      (:first-time (first-time-clause state))
+      (:last-time (last-time-clause state))

       (otherwise (push (body-clause term state) (body state))))))
 
 (defun parse-ps-loop (terms)
       (otherwise (push (body-clause term state) (body state))))))
 
 (defun parse-ps-loop (terms)


@@ -194,39 +206,61 @@
         (loop :while (tokens state) :do (clause state))
         (nreverse-loop-state state))))
 
         (loop :while (tokens state) :do (clause state))
         (nreverse-loop-state state))))
 

-(defun init-forms (loop)
+(defun multiple-fors? (loop)
+  (> (length (iterations loop)) 1))
+
+(defun inits (loop)

   (mapcar (lambda (x) (subseq x 0 2)) (iterations loop)))
 
   (mapcar (lambda (x) (subseq x 0 2)) (iterations loop)))
 

-(defun step-forms (loop)
+(defun steps (loop)

   (mapcar (lambda (x) `(setf ,(first x) ,(third x))) (iterations loop)))
 
 (defun end-test (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)
+  (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))
        (if (cdr it)
            (list 'not (cons 'or it))
            (cons 'not it))

-       '(not nil)))
+       t))
+
+(defun inner-body (loop)
+  (if (multiple-fors? loop)
+      (append (body loop)
+              (loop :for (var nil step test) :in (iterations loop)
+                :collect `(setf ,var ,step)
+                :when test :collect `(when ,test (break))))
+      (body loop)))
+
+(defun the-actual-loop (loop)
+  (let ((body `(,@(awhen (during-first loop)
+                         `((when ,(first-guard loop)
+                             ,@it
+                             (setf ,(first-guard loop) nil))))
+                  ,@(inner-body loop)
+                  ,@(when (during-last loop)
+                          `((setf ,(last-guard loop) t))))))
+    (if (multiple-fors? loop)
+        `(while t ,@body)
+        `(for ,(inits loop) (,(end-test loop)) ,(steps loop) ,@body))))
+
+(defun the-loop-form (loop)
+  (let ((form `(progn
+                 ,@(initially loop)
+                 ,(the-actual-loop loop)
+                 ,@(awhen (during-last loop)
+                          `((when ,(last-guard loop) ,@it)))
+                 ,@(finally loop))))
+    (when (multiple-fors? loop)
+      (loop :for (var init nil test) :in (reverse (iterations loop))
+        :when test :do (setf form `(unless ,test ,form))
+        :do (setf form `(let ((,var ,init)) ,form))))
+    form))

 
 (defpsmacro loop (&rest args)
 
 (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))))
+  (let ((loop (parse-ps-loop (normalize-loop-keywords args))))

     `(,@(if (default-accum-var loop) '(with-lambda ()) '(progn))
     `(,@(if (default-accum-var loop) '(with-lambda ()) '(progn))

-        ,@(when (during-first loop) `((var ,first-guard t)))
-        ,@(when (during-last loop) `((var ,last-guard nil)))
+        ,@(when (during-first loop) `((var ,(first-guard loop) t)))
+        ,@(when (during-last loop) `((var ,(last-guard loop) nil)))

         ,@(prologue loop)
         ,@(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)
+        ,(the-loop-form loop)

         ,@(when (default-accum-var loop) `((return ,(default-accum-var loop)))))))
         ,@(when (default-accum-var loop) `((return ,(default-accum-var loop)))))))