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 parse-ps-loop (terms)
  28   (let (prologue
  29         init-step-forms end-test-forms
  30         initially finally
  31         first-time last-time
  32         default-accum-var default-accum-kind
  33         destructurings body)
  34     (macrolet ((with-local-var ((name expr) &body body)
  35                  (once-only (expr)
  36                    `(let ((,name (aif (and (complex-js-expr? ,expr) (ps-gensym))
  37                                       (progn (push (list 'var it ,expr) prologue)
  38                                              it)
  39                                       ,expr)))
  40                       ,@body))))
  41       (labels ((next ()
  42                  (car terms))
  43                (next? (term)
  44                  (eq (next) term))
  45                (err (expected got)
  46                  (error "PS-LOOP expected ~a, got ~a." expected got))
  47                (consume (&optional what)
  48                  (let ((term (pop terms)))
  49                    (when (and what (not (eq what term)))
  50                      (err what term))
  51                    term))
  52                (consume-atom ()
  53                  (if (atom (next))
  54                      (consume)
  55                      (err "an atom" (next))))
  56                (consume-progn ()
  57                  (cons 'progn (loop :collect (if (consp (next))
  58                                                  (consume)
  59                                                  (err "a compound form" (next)))
  60                                 :until (atom (next)))))
  61                (consume-if (term)
  62                  (when (next? term)
  63                    (consume)
  64                    (consume)))
  65                (accumulate (kind term var)
  66                  (when (null var)
  67                    (when (and default-accum-kind (not (eq kind default-accum-kind)))
  68                      (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))
  69                    (unless default-accum-var
  70                      (setf default-accum-var (ps-gensym (case kind
  71                                                           (:minimize 'min)
  72                                                           (:maximize 'max)
  73                                                           (t kind)))
  74                            default-accum-kind kind))
  75                    (setf var default-accum-var))
  76                  (let ((initial (case kind
  77                                   ((:sum :count) 0)
  78                                   ((:maximize :minimize) nil)
  79                                   (:collect '(array)))))
  80                    (pushnew `(var ,var ,initial) prologue :key #'second))
  81                  (case kind
  82                    (:sum `(incf ,var ,term))
  83                    (:count `(unless (null ,term) (incf ,var)))
  84                    (:minimize `(setf ,var (if (null ,var) ,term (min ,var ,term))))
  85                    (:maximize `(setf ,var (if (null ,var) ,term (max ,var ,term))))
  86                    (:collect `((@ ,var :push) ,term))))
  87                (body-clause (term)
  88                  (case term
  89                    ((:when :unless) (list (intern (symbol-name term))
  90                                           (consume)
  91                                           (body-clause (consume-atom))))
  92                    ((:sum :collect :count :minimize :maximize) (accumulate term (consume) (consume-if :into)))
  93                    (:do (consume-progn))
  94                    (otherwise (err "a PS-LOOP keyword" term))))
  95                (for-from (var)
  96                  (let ((start (consume))
  97                        (op '+)
  98                        (test nil)
  99                        (by nil)
 100                        (end nil))
 101                    (loop while (member (next) '(:to :below :downto :above :by)) do
 102                          (let ((term (consume)))
 103                            (if (eq term :by)
 104                                (setf by (consume))
 105                                (setf op (case term ((:downto :above) '-) (otherwise '+))
 106                                      test (case term (:to '>) (:below '>=) (:downto '<) (:above '<=))
 107                                      end (consume)))))
 108                    (push `(,var ,start (,op ,var ,(or by 1))) init-step-forms)
 109                    (when test
 110                      (with-local-var (end-var end)
 111                        (push (list test var end-var) end-test-forms)))))
 112                (for-= (var)
 113                  (let ((start (consume))
 114                        (then (consume-if :then)))
 115                    (push (list var start (or then start)) init-step-forms)))
 116                (for-in (var)
 117                  (with-local-var (arr (consume))
 118                    (let* ((index (or (consume-if :index) (ps-gensym)))
 119                           (equiv `(:for ,index :from 0 :below (length ,arr)
 120                                         :for ,var := (aref ,arr ,index))))
 121                      (setf terms (append equiv terms))
 122                      (clause)
 123                      (clause))))
 124                (for-on (var)
 125                  (with-local-var (arr (consume))
 126                    (push `(or (null ,var) (= (length ,var) 0)) end-test-forms)
 127                    (let* ((by (aif (consume-if :by)
 128                                    `(,(reduce-function-symbol it) ,var)
 129                                    `((@ ,var :slice) 1)))
 130                           (equiv `(:for ,var := ,arr :then ,by)))
 131                      (setf terms (append equiv terms))
 132                      (clause))))
 133                (for-clause ()
 134                  (let* ((place (consume))
 135                         (var (when (atom place) place))
 136                         (varlist (unless var place))
 137                         (term (consume-atom)))
 138                    (when varlist
 139                      (when (eq term :from)
 140                        (err "an atom after FOR" varlist))
 141                      (setf var (ps-gensym))
 142                      (push (list varlist var) destructurings))
 143                    (case term
 144                      (:from (for-from var))
 145                      (:= (for-= var))
 146                      ((:in :across) (for-in var))
 147                      (:on (for-on var))
 148                      (otherwise (error "FOR ~s ~s is not valid in PS-LOOP." var term)))))
 149                (repeat-clause ()
 150                  (let ((index (ps-gensym)))
 151                    (setf terms (append `(:for ,index :from 0 :below ,(consume)) terms))
 152                    (clause)))
 153                (clause ()
 154                  (let ((term (consume-atom)))
 155                    (case term
 156                      (:for (for-clause))
 157                      (:repeat (repeat-clause))
 158                      (:while (push `(unless ,(consume) break) body))
 159                      (:until (push `(when ,(consume) break) body))
 160                      (:initially (push (consume-progn) initially))
 161                      (:finally (push (consume-progn) finally))
 162                      (:first-time (push (consume-progn) first-time))
 163                      (:last-time (push (consume-progn) last-time))
 164                      (otherwise (push (body-clause term) body))))))
 165         (if terms
 166             (loop :while terms :do (clause))
 167             (err "loop definition" nil)))
 168       (flet ((end-test ()
 169                (aif (nreverse end-test-forms)
 170                     (if (cdr it)
 171                         (list (cons 'or it))
 172                         it)
 173                     (list nil)))
 174              (add-destructurings-to-body ()
 175                (setf body (nreverse body))
 176                (loop :for (list var) :in destructurings :do
 177                  (setf body `((destructuring-bind ,list ,var ,@body))))
 178                body))
 179         (values (nreverse prologue)
 180                 (nreverse init-step-forms)
 181                 (end-test)
 182                 (nreverse initially)
 183                 (nreverse finally)
 184                 (nreverse first-time)
 185                 (nreverse last-time)
 186                 default-accum-var
 187                 (add-destructurings-to-body))))))
 188
 189 (defpsmacro loop (&rest args)
 190   (multiple-value-bind (prologue
 191                         init-step-forms end-test
 192                         initially finally
 193                         first-time last-time
 194                         default-accum-var
 195                         body)
 196       (parse-ps-loop (normalize-loop-keywords args))
 197     (let ((first-guard (and first-time (ps-gensym)))
 198           (last-guard (and last-time (ps-gensym))))
 199       `(,@(if default-accum-var '(with-lambda ()) '(progn))
 200           ,@(when first-time `((var ,first-guard t)))
 201           ,@(when last-time `((var ,last-guard nil)))
 202           ,@prologue
 203           ,@initially
 204           (do* ,init-step-forms
 205                ,end-test
 206             ,@(when first-time
 207                     `((when ,first-guard
 208                         ,@first-time
 209                         (setf ,first-guard nil))))
 210             ,@body
 211             ,@(when last-time
 212                     `((setf ,last-guard t))))
 213           ,@(when last-time `((when ,last-guard ,@last-time)))
 214           ,@finally
 215           ,@(when default-accum-var `((return ,default-accum-var)))))))