src/lib/ps-loop.lisp

   1 (in-package :parenscript)
   2
   3 (defun complex-js-expr? (expr)
   4   (if (symbolp expr)
   5       (or (find #\. (symbol-name expr))
   6           (not (eq (ps-macroexpand expr) expr)))
   7       (consp expr)))
   8
   9 (defvar *loop-keywords*
  10   '(:for :do :when :unless :initially :finally :first-time :last-time :while :until
  11     :from :to :below :downto :above :by :in :across :on :index := :then :sum :collect
  12     :count :minimize :maximize :into :repeat))
  13
  14 (defun normalize-loop-keywords (args)
  15   (mapcar
  16    (lambda (x)
  17      (or (find-if (lambda (key) (and (symbolp x) (equal (symbol-name x) (symbol-name key))))
  18                   *loop-keywords*)
  19          x))
  20    args))
  21
  22 (defun reduce-function-symbol (sym)
  23   (if (and (consp sym) (eq 'function (first sym)))
  24       (second sym)
  25       sym))
  26
  27 (defun err (expected got)
  28   (error "PS-LOOP expected ~a, got ~a." expected got))
  29
  30 (defclass loop-state ()
  31   ((tokens :initarg :tokens :accessor tokens)
  32    (iterations :initform nil :accessor iterations)
  33    (prologue :initform nil :accessor prologue)
  34    (initially :initform nil :accessor initially)
  35    (finally :initform nil :accessor finally)
  36    (during-first :initform nil :accessor during-first)
  37    (first-guard :initform nil :accessor first-guard)
  38    (during-last :initform nil :accessor during-last)
  39    (last-guard :initform nil :accessor last-guard)
  40    (default-accum-var :initform nil :accessor default-accum-var)
  41    (default-accum-kind :initform nil :accessor default-accum-kind)
  42    (body :initform nil :accessor body)))
  43
  44 (defun nreverse-loop-state (state)
  45   (macrolet ((rev% (&rest accs)
  46                (cons 'progn (loop :for a :in accs :collect `(setf (,a state) (nreverse (,a state)))))))
  47     (rev% iterations prologue initially finally during-first during-last body))
  48   state)
  49
  50 (defun push-tokens (state toks)
  51   (setf (tokens state) (append toks (tokens state))))
  52
  53 (defun peek (state)
  54   (car (tokens state)))
  55
  56 (defun eat (state &optional what tag)
  57   (case what
  58     (:if (when (eq (peek state) tag)
  59            (eat state)
  60            (eat state)))
  61     (:progn (cons 'progn (loop :collect (if (consp (peek state))
  62                                             (eat state)
  63                                             (err "a compound form" (peek state)))
  64                            :until (atom (peek state)))))
  65     (otherwise (let ((tok (pop (tokens state))))
  66                  (when (and (eq what :atom) (not (atom tok)))
  67                    (err "an atom" tok))
  68                  tok))))
  69
  70 (defmacro with-local-var ((name expr state) &body body)
  71   (once-only (expr)
  72     `(let ((,name (aif (and (complex-js-expr? ,expr) (ps-gensym))
  73                        (progn (push (list 'var it ,expr) (prologue ,state))
  74                               it)
  75                        ,expr)))
  76        ,@body)))
  77
  78 (defun for-from (var state)
  79   (let ((start (eat state))
  80         (op '+)
  81         (test-op nil)
  82         (by nil)
  83         (end nil))
  84     (loop while (member (peek state) '(:to :below :downto :above :by)) do
  85           (let ((term (eat state)))
  86             (if (eq term :by)
  87                 (setf by (eat state))
  88                 (setf op (case term ((:downto :above) '-) (otherwise '+))
  89                       test-op (case term (:to '>) (:below '>=) (:downto '<) (:above '<=))
  90                       end (eat state)))))
  91     (let ((test (when test-op
  92                   (with-local-var (v end state)
  93                     (list test-op var v)))))
  94       (push `(,var nil ,start (,op ,var ,(or by 1)) ,test) (iterations state)))))
  95
  96 (defun for-= (var bindings state)
  97   (let ((start (eat state))
  98         (then (eat state :if :then)))
  99     (push (list var bindings start (or then start) nil) (iterations state))))
 100
 101 (defun for-in (var bindings state)
 102   (with-local-var (arr (eat state) state)
 103     (let ((index (or (eat state :if :index) (ps-gensym))))
 104       (push-tokens state `(,index :from 0 :below (length ,arr)
 105                                   ,var := (aref ,arr ,index)))
 106       (for-clause state)
 107       (for-clause state)
 108       ;; set bindings associated with original clause, e.g. "loop :for (a b) :in c"
 109       (setf (second (car (iterations state))) bindings))))
 110
 111 (defun for-on (var bindings state)
 112   (with-local-var (arr (eat state) state)
 113     (let ((by (aif (eat state :if :by)
 114                    `(,(reduce-function-symbol it) ,var)
 115                    `((@ ,var :slice) 1))))
 116       (push-tokens state `(,var := ,arr :then ,by))
 117       (for-clause state)
 118       (let ((this-iteration (car (iterations state))))
 119         (setf (second this-iteration) bindings)
 120         ;; set the end-test
 121         (setf (fifth this-iteration) `(or (null ,var) (= (length ,var) 0)))))))
 122
 123 (defun for-clause (state)
 124   (let* ((place (eat state))
 125          (var (when (atom place) place))
 126          (bindings (unless var place))
 127          (term (eat state :atom)))
 128     (when bindings
 129       (when (eq term :from)
 130         (err "an atom after FROM" bindings))
 131       (setf var (ps-gensym)))
 132     (case term
 133       (:from (for-from var state))
 134       (:= (for-= var bindings state))
 135       ((:in :across) (for-in var bindings state))
 136       (:on (for-on var bindings state))
 137       (otherwise (error "FOR ~s ~s is not valid in PS-LOOP." var term)))))
 138
 139 (defun accumulate (kind term var state)
 140   (when (null var)
 141     (when (and (default-accum-kind state) (not (eq kind (default-accum-kind state))))
 142       (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)))
 143     (unless (default-accum-var state)
 144       (setf (default-accum-var state)
 145             (ps-gensym (case kind
 146                          (:minimize 'min)
 147                          (:maximize 'max)
 148                          (t kind))))
 149       (setf (default-accum-kind state) kind))
 150     (setf var (default-accum-var state)))
 151   (let ((initial (case kind
 152                    ((:sum :count) 0)
 153                    ((:maximize :minimize) nil)
 154                    (:collect '(array)))))
 155     (pushnew `(var ,var ,initial) (prologue state) :key #'second))
 156   (case kind
 157     (:sum `(incf ,var ,term))
 158     (:count `(unless (null ,term) (incf ,var)))
 159     (:minimize `(setf ,var (if (null ,var) ,term (min ,var ,term))))
 160     (:maximize `(setf ,var (if (null ,var) ,term (max ,var ,term))))
 161     (:collect `((@ ,var :push) ,term))))
 162
 163 (defun first-time-clause (state)
 164   (push (eat state :progn) (during-first state))
 165   (unless (first-guard state)
 166     (setf (first-guard state) (ps-gensym))))
 167
 168 (defun last-time-clause (state)
 169   (push (eat state :progn) (during-last state))
 170   (unless (last-guard state)
 171     (setf (last-guard state) (ps-gensym))))
 172
 173 (defun repeat-clause (state)
 174   (let ((index (ps-gensym)))
 175     (setf (tokens state) (append `(,index :from 0 :below ,(eat state)) (tokens state)))
 176     (for-clause state)))
 177
 178 (defun body-clause (term state)
 179   (case term
 180     ((:when :unless) (list (intern (symbol-name term))
 181                            (eat state)
 182                            (body-clause (eat state :atom) state)))
 183     ((:sum :collect :count :minimize :maximize) (accumulate term (eat state) (eat state :if :into) state))
 184     (:do (eat state :progn))
 185     (otherwise (err "a PS-LOOP keyword" term))))
 186
 187 (defun clause (state)
 188   (let ((term (eat state :atom)))
 189     (case term
 190       (:for (for-clause state))
 191       (:repeat (repeat-clause state))
 192       (:while (push `(unless ,(eat state) break) (body state)))
 193       (:until (push `(when ,(eat state) break) (body state)))
 194       (:initially (push (eat state :progn) (initially state)))
 195       (:finally (push (eat state :progn) (finally state)))
 196       (:first-time (first-time-clause state))
 197       (:last-time (last-time-clause state))
 198       (otherwise (push (body-clause term state) (body state))))))
 199
 200 (defun parse-ps-loop (terms)
 201   (if (null terms)
 202       (err "loop definition" nil)
 203       (let ((state (make-instance 'loop-state :tokens terms)))
 204         (loop :while (tokens state) :do (clause state))
 205         (nreverse-loop-state state))))
 206
 207 (defun multiple-fors? (loop)
 208   (> (length (iterations loop)) 1))
 209
 210 (defun inits (loop)
 211   (mapcar (lambda (x) (list (first x) (third x)))
 212           (iterations loop)))
 213
 214 (defun steps (loop)
 215   (mapcar (lambda (x) `(setf ,(first x) ,(fourth x)))
 216           (iterations loop)))
 217
 218 (defun end-test (loop)
 219   (aif (loop :for (nil nil nil nil test) :in (iterations loop)
 220          :when test :collect test)
 221        (if (cdr it)
 222            (list 'not (cons 'or it))
 223            (cons 'not it))
 224        t))
 225
 226 (defun wrap-with-destructurings (iterations forms)
 227   (if (null iterations)
 228       forms
 229       (wrap-with-destructurings
 230        (cdr iterations)
 231        (aif (second (car iterations))
 232             `((destructuring-bind ,it ,(first (car iterations)) ,@forms))
 233             forms))))
 234
 235 (defun outer-body (loop)
 236   (wrap-with-destructurings
 237    (iterations loop)
 238    (append (body loop)
 239            (loop :for (var nil nil step test) :in (iterations loop)
 240              :collect `(setf ,var ,step)
 241              :when test :collect `(when ,test (break))))))
 242
 243 (defun init-and-test (iterations form)
 244   (loop :for (var nil init nil test) :in (reverse iterations) :do
 245     (when test
 246       (setf form `(unless ,test ,form)))
 247     ;; (when bindings
 248     ;;   (setf form `(destructuring-bind ,bindings ,var ,form)))
 249     (setf form `(let ((,var ,init)) ,form)))
 250   form)
 251
 252 (defun loop-form-with-alternating-tests (loop)
 253   (let ((form `(progn
 254                  ,@(initially loop)
 255                  (while t
 256                    ,@(awhen (during-first loop)
 257                             `((when ,(first-guard loop)
 258                                 ,@it
 259                                 (setf ,(first-guard loop) nil))))
 260                    ,@(outer-body loop)
 261                    ,@(when (during-last loop)
 262                            `((setf ,(last-guard loop) t))))
 263                  ,@(awhen (during-last loop)
 264                           `((when ,(last-guard loop) ,@it)))
 265                  ,@(finally loop))))
 266     (init-and-test (iterations loop) form)))
 267
 268 (defun simple-for-form (loop)
 269   `(progn
 270      ,@(initially loop)
 271      (for ,(inits loop) (,(end-test loop)) ,(steps loop)
 272           ,@(awhen (during-first loop)
 273                    `((when ,(first-guard loop)
 274                        ,@it
 275                        (setf ,(first-guard loop) nil))))
 276           ,@(wrap-with-destructurings (iterations loop) (body loop))
 277           ,@(when (during-last loop)
 278                   `((setf ,(last-guard loop) t))))
 279      ,@(awhen (during-last loop)
 280               `((when ,(last-guard loop) ,@it)))
 281      ,@(finally loop)))
 282
 283 (defpsmacro loop (&rest args)
 284   (let ((loop (parse-ps-loop (normalize-loop-keywords args))))
 285     `(,@(if (default-accum-var loop) '(with-lambda ()) '(progn))
 286         ,@(when (during-first loop) `((var ,(first-guard loop) t)))
 287         ,@(when (during-last loop) `((var ,(last-guard loop) nil)))
 288         ,@(prologue loop)
 289         ,(if (multiple-fors? loop)
 290              (loop-form-with-alternating-tests loop)
 291              (simple-for-form loop))
 292         ,@(when (default-accum-var loop) `((return ,(default-accum-var loop)))))))