| 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 | (destructurings :initform nil :accessor destructurings) |
| 35 | (initially :initform nil :accessor initially) |
| 36 | (finally :initform nil :accessor finally) |
| 37 | (during-first :initform nil :accessor during-first) |
| 38 | (during-last :initform nil :accessor during-last) |
| 39 | (default-accum-var :initform nil :accessor default-accum-var) |
| 40 | (default-accum-kind :initform nil :accessor default-accum-kind) |
| 41 | (body :initform nil :accessor body))) |
| 42 | |
| 43 | (defun nreverse-loop-state (state) |
| 44 | (macrolet ((rev% (&rest accs) |
| 45 | (cons 'progn (loop :for a :in accs :collect `(setf (,a state) (nreverse (,a state))))))) |
| 46 | (rev% iterations prologue initially finally during-first during-last) |
| 47 | (let ((body (nreverse (body state)))) |
| 48 | (loop :for (list var) :in (destructurings state) :do |
| 49 | (setf body `((destructuring-bind ,list ,var ,@body)))) |
| 50 | (setf (body state) body))) |
| 51 | state) |
| 52 | |
| 53 | (defun push-tokens (state toks) |
| 54 | (setf (tokens state) (append toks (tokens state)))) |
| 55 | |
| 56 | (defun peek (state) |
| 57 | (car (tokens state))) |
| 58 | |
| 59 | (defun eat (state &optional what tag) |
| 60 | (case what |
| 61 | (:if (when (eq (peek state) tag) |
| 62 | (eat state) |
| 63 | (eat state))) |
| 64 | (:progn (cons 'progn (loop :collect (if (consp (peek state)) |
| 65 | (eat state) |
| 66 | (err "a compound form" (peek state))) |
| 67 | :until (atom (peek state))))) |
| 68 | (otherwise (let ((tok (pop (tokens state)))) |
| 69 | (when (and (eq what :atom) (not (atom tok))) |
| 70 | (err "an atom" tok)) |
| 71 | tok)))) |
| 72 | |
| 73 | (defmacro with-local-var ((name expr state) &body body) |
| 74 | (once-only (expr) |
| 75 | `(let ((,name (aif (and (complex-js-expr? ,expr) (ps-gensym)) |
| 76 | (progn (push (list 'var it ,expr) (prologue ,state)) |
| 77 | it) |
| 78 | ,expr))) |
| 79 | ,@body))) |
| 80 | |
| 81 | (defun for-from (var state) |
| 82 | (let ((start (eat state)) |
| 83 | (op '+) |
| 84 | (test-op nil) |
| 85 | (by nil) |
| 86 | (end nil)) |
| 87 | (loop while (member (peek state) '(:to :below :downto :above :by)) do |
| 88 | (let ((term (eat state))) |
| 89 | (if (eq term :by) |
| 90 | (setf by (eat state)) |
| 91 | (setf op (case term ((:downto :above) '-) (otherwise '+)) |
| 92 | test-op (case term (:to '>) (:below '>=) (:downto '<) (:above '<=)) |
| 93 | end (eat state))))) |
| 94 | (let ((test (when test-op |
| 95 | (with-local-var (v end state) |
| 96 | (list test-op var v))))) |
| 97 | (push `(,var ,start (,op ,var ,(or by 1)) ,test) (iterations state))))) |
| 98 | |
| 99 | (defun for-= (var state) |
| 100 | (let ((start (eat state)) |
| 101 | (then (eat state :if :then))) |
| 102 | (push (list var start (or then start) nil) (iterations state)))) |
| 103 | |
| 104 | (defun for-in (var state) |
| 105 | (with-local-var (arr (eat state) state) |
| 106 | (let ((index (or (eat state :if :index) (ps-gensym)))) |
| 107 | (push-tokens state `(,index :from 0 :below (length ,arr) |
| 108 | ,var := (aref ,arr ,index))) |
| 109 | (for-clause state) |
| 110 | (for-clause state)))) |
| 111 | |
| 112 | (defun for-on (var state) |
| 113 | (with-local-var (arr (eat state) state) |
| 114 | (let ((by (aif (eat state :if :by) |
| 115 | `(,(reduce-function-symbol it) ,var) |
| 116 | `((@ ,var :slice) 1)))) |
| 117 | (push-tokens state `(,var := ,arr :then ,by)) |
| 118 | (for-clause state) |
| 119 | ;; set the end-test |
| 120 | (setf (fourth (car (iterations state))) `(or (null ,var) (= (length ,var) 0)))))) |
| 121 | |
| 122 | (defun for-clause (state) |
| 123 | (let* ((place (eat state)) |
| 124 | (var (when (atom place) place)) |
| 125 | (varlist (unless var place)) |
| 126 | (term (eat state :atom))) |
| 127 | (when varlist |
| 128 | (when (eq term :from) |
| 129 | (err "an atom after FROM" varlist)) |
| 130 | (setf var (ps-gensym)) |
| 131 | (push (list varlist var) (destructurings state))) |
| 132 | (case term |
| 133 | (:from (for-from var state)) |
| 134 | (:= (for-= var state)) |
| 135 | ((:in :across) (for-in var state)) |
| 136 | (:on (for-on var 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 repeat-clause (state) |
| 164 | (let ((index (ps-gensym))) |
| 165 | (setf (tokens state) (append `(,index :from 0 :below ,(eat state)) (tokens state))) |
| 166 | (for-clause state))) |
| 167 | |
| 168 | (defun body-clause (term state) |
| 169 | (case term |
| 170 | ((:when :unless) (list (intern (symbol-name term)) |
| 171 | (eat state) |
| 172 | (body-clause (eat state :atom) state))) |
| 173 | ((:sum :collect :count :minimize :maximize) (accumulate term (eat state) (eat state :if :into) state)) |
| 174 | (:do (eat state :progn)) |
| 175 | (otherwise (err "a PS-LOOP keyword" term)))) |
| 176 | |
| 177 | (defun clause (state) |
| 178 | (let ((term (eat state :atom))) |
| 179 | (case term |
| 180 | (:for (for-clause state)) |
| 181 | (:repeat (repeat-clause state)) |
| 182 | (:while (push `(unless ,(eat state) break) (body state))) |
| 183 | (:until (push `(when ,(eat state) break) (body state))) |
| 184 | (:initially (push (eat state :progn) (initially state))) |
| 185 | (:finally (push (eat state :progn) (finally state))) |
| 186 | (:first-time (push (eat state :progn) (during-first state))) |
| 187 | (:last-time (push (eat state :progn) (during-last state))) |
| 188 | (otherwise (push (body-clause term state) (body state)))))) |
| 189 | |
| 190 | (defun parse-ps-loop (terms) |
| 191 | (if (null terms) |
| 192 | (err "loop definition" nil) |
| 193 | (let ((state (make-instance 'loop-state :tokens terms))) |
| 194 | (loop :while (tokens state) :do (clause state)) |
| 195 | (nreverse-loop-state state)))) |
| 196 | |
| 197 | (defun init-forms (loop) |
| 198 | (mapcar (lambda (x) (subseq x 0 2)) (iterations loop))) |
| 199 | |
| 200 | (defun step-forms (loop) |
| 201 | (mapcar (lambda (x) `(setf ,(first x) ,(third x))) (iterations loop))) |
| 202 | |
| 203 | (defun end-test (loop) |
| 204 | (aif (loop :for (nil nil nil test) :in (iterations loop) :when test :collect test) |
| 205 | (if (cdr it) |
| 206 | (list 'not (cons 'or it)) |
| 207 | (cons 'not it)) |
| 208 | '(not nil))) |
| 209 | |
| 210 | (defpsmacro loop (&rest args) |
| 211 | (let* ((loop (parse-ps-loop (normalize-loop-keywords args))) |
| 212 | (first-guard (and (during-first loop) (ps-gensym))) |
| 213 | (last-guard (and (during-last loop) (ps-gensym)))) |
| 214 | `(,@(if (default-accum-var loop) '(with-lambda ()) '(progn)) |
| 215 | ,@(when (during-first loop) `((var ,first-guard t))) |
| 216 | ,@(when (during-last loop) `((var ,last-guard nil))) |
| 217 | ,@(prologue loop) |
| 218 | ,@(initially loop) |
| 219 | (for ,(init-forms loop) |
| 220 | (,(end-test loop)) |
| 221 | ,(step-forms loop) |
| 222 | ,@(when (during-first loop) |
| 223 | `((when ,first-guard |
| 224 | ,@(during-first loop) |
| 225 | (setf ,first-guard nil)))) |
| 226 | ,@(body loop) |
| 227 | ,@(when (during-last loop) |
| 228 | `((setf ,last-guard t)))) |
| 229 | ,@(when (during-last loop) |
| 230 | `((when ,last-guard ,@(during-last loop)))) |
| 231 | ,@(finally loop) |
| 232 | ,@(when (default-accum-var loop) `((return ,(default-accum-var loop))))))) |