(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)
+ (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)))
(: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)))
(: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)
(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)))
-(defun step-forms (loop)
+(defun steps (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))
- '(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)
- (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))
- ,@(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)
- ,@(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)))))))