src/lib/ps-loop.lisp

   1 (in-package :parenscript)
   2
   3 (defmacro aif (test-form then-form &optional else-form)
   4   `(let ((it ,test-form))
   5      (if it ,then-form ,else-form)))
   6
   7 (defmacro once-only ((&rest names) &body body) ;; the version from PCL
   8   (let ((gensyms (loop for nil in names collect (gensym))))
   9     `(let (,@(loop for g in gensyms collect `(,g (gensym))))
  10        `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
  11           ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
  12                 ,@body)))))
  13
  14 (defun complex-js-expr? (expr)
  15   (if (symbolp expr)
  16       (find #\. (symbol-name expr))
  17       (consp expr)))
  18
  19 (defvar *loop-clauses* '(:for :do :when :unless :initially :finally :first-time :last-time :while :until))
  20 (defvar *loop-keywords*
  21   (append *loop-clauses* '(:from :to :below :downto :above :by :in :across :index := :then :sum :into)))
  22
  23 (defun normalize-loop-keywords (args)
  24   (mapcar (lambda (x)
  25             (or (find-if (lambda (key) (eq x (intern (string key))))
  26                          *loop-keywords*)
  27                 x))
  28           args))
  29
  30 (defun parse-js-loop (terms)
  31   (let (prologue
  32         init-step-forms end-test-forms
  33         initially finally
  34         first-time last-time
  35         body)
  36     (macrolet ((with-local-var ((name expr) &body body)
  37                  (once-only (expr)
  38                    `(let ((,name (aif (and (complex-js-expr? ,expr) (ps-gensym))
  39                                       (progn (push (list 'var it ,expr) prologue)
  40                                              it)
  41                                       ,expr)))
  42                       ,@body))))
  43       (labels ((next ()
  44                  (car terms))
  45                (next? (term)
  46                  (eq (next) term))
  47                (err (expected got)
  48                  (error "JS-LOOP expected ~s, got ~s." expected got))
  49                (consume (&optional what)
  50                  (let ((term (pop terms)))
  51                    (when (and what (not (eq what term)))
  52                      (err what term))
  53                    term))
  54                (consume-atom ()
  55                  (if (atom (next))
  56                      (consume)
  57                      (err "an atom" (next))))
  58                (consume-progn ()
  59                  (cons 'progn (loop :collect (if (consp (next))
  60                                                  (consume)
  61                                                  (err "a compound form" (next)))
  62                                 :until (atom (next)))))
  63                (consume-if (term)
  64                  (when (next? term)
  65                    (consume)
  66                    (consume)))
  67                (body-clause (term)
  68                  (case term
  69                    ((:when :unless) (list (intern (symbol-name term))
  70                                           (consume)
  71                                           (body-clause (consume-atom))))
  72                    (:sum (let ((sum-expr (consume)))
  73                            (consume :into)
  74                            (let ((sum-var (consume-atom)))
  75                              (push `(var ,sum-var 0) prologue)
  76                              `(incf ,sum-var ,sum-expr))))
  77                    (:do (consume-progn))
  78                    (otherwise (err "a JS-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 ((var (consume-atom))
 110                        (term (consume-atom)))
 111                    (case term
 112                      (:from (for-from var))
 113                      (:= (for-= var))
 114                      ((:in :across) (for-in var))
 115                      (otherwise (error "FOR ~s ~s is not valid in JS-LOOP." var term)))))
 116                (clause ()
 117                  (let ((term (consume-atom)))
 118                    (case term
 119                      (:for (for-clause))
 120                      (:while (push `(unless ,(consume) break) body))
 121                      (:until (push `(when ,(consume) break) body))
 122                      (:initially (push (consume-progn) initially))
 123                      (:finally (push (consume-progn) finally))
 124                      (:first-time (push (consume-progn) first-time))
 125                      (:last-time (push (consume-progn) last-time))
 126                      (otherwise (push (body-clause term) body))))))
 127         (if terms
 128             (loop :while terms :do (clause))
 129             (err "loop definition" nil))
 130         (values (nreverse prologue)
 131                 (nreverse init-step-forms)
 132                 (aif (nreverse end-test-forms)
 133                      (if (cdr it)
 134                          (list (cons 'or it))
 135                          it)
 136                      (list nil))
 137                 (nreverse initially)
 138                 (nreverse finally)
 139                 (nreverse first-time)
 140                 (nreverse last-time)
 141                 (nreverse body))))))
 142
 143 (defpsmacro loop (&rest args)
 144   (multiple-value-bind (prologue
 145                         init-step-forms end-test-forms
 146                         initially finally
 147                         first-time last-time
 148                         body)
 149       (parse-js-loop (normalize-loop-keywords args))
 150     (let ((first-guard (and first-time (ps-gensym)))
 151           (last-guard (and last-time (ps-gensym))))
 152       `(progn ,@(when first-time `((var ,first-guard t)))
 153               ,@(when last-time `((var ,last-guard nil)))
 154               ,@prologue
 155               ,@initially
 156               (do* ,init-step-forms
 157                    ,end-test-forms
 158                 ,@(when first-time
 159                         `((when ,first-guard
 160                             ,@first-time
 161                             (setf ,first-guard nil))))
 162                 ,@body
 163                 ,@(when last-time
 164                         `((setf ,last-guard t))))
 165               ,@(when last-time `((when ,last-guard ,@last-time)))
 166               ,@finally))))