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

[clinton/parenscript.git] / src / lib / ps-loop.lisp

(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)
   (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)))

(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 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)))
    (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 (first-time-clause state))
      (:last-time (last-time-clause 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 multiple-fors? (loop)
  (> (length (iterations loop)) 1))

(defun inits (loop)
  (mapcar (lambda (x) (subseq x 0 2)) (iterations 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)
       (if (cdr it)
           (list 'not (cons 'or it))
           (cons 'not it))
       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))))
    `(,@(if (default-accum-var loop) '(with-lambda ()) '(progn))
        ,@(when (during-first loop) `((var ,(first-guard loop) t)))
        ,@(when (during-last loop) `((var ,(last-guard loop) nil)))
        ,@(prologue loop)
        ,(the-loop-form loop)
        ,@(when (default-accum-var loop) `((return ,(default-accum-var loop)))))))