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