src/lib/ps-loop.lisp

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