Commit | Line | Data |
---|---|---|
e4ee1b86 DG |
1 | (in-package :parenscript) |
2 | ||
e4ee1b86 DG |
3 | (defun complex-js-expr? (expr) |
4 | (if (symbolp expr) | |
70c34384 DG |
5 | (or (find #\. (symbol-name expr)) |
6 | (not (eq (ps-macroexpand expr) expr))) | |
e4ee1b86 DG |
7 | (consp expr))) |
8 | ||
e4ee1b86 | 9 | (defvar *loop-keywords* |
a3939827 | 10 | '(:for :do :when :unless :initially :finally :first-time :last-time :while :until |
70c34384 | 11 | :from :to :below :downto :above :by :in :across :on :index := :then :sum :collect |
578e8565 | 12 | :count :minimize :maximize :into :repeat)) |
e4ee1b86 DG |
13 | |
14 | (defun normalize-loop-keywords (args) | |
512017c6 DG |
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)) | |
e4ee1b86 | 21 | |
70c34384 DG |
22 | (defun reduce-function-symbol (sym) |
23 | (if (and (consp sym) (eq 'function (first sym))) | |
24 | (second sym) | |
25 | sym)) | |
26 | ||
2100b87b DG |
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) | |
2100b87b DG |
34 | (initially :initform nil :accessor initially) |
35 | (finally :initform nil :accessor finally) | |
36 | (during-first :initform nil :accessor during-first) | |
56ae43a5 | 37 | (first-guard :initform nil :accessor first-guard) |
2100b87b | 38 | (during-last :initform nil :accessor during-last) |
56ae43a5 | 39 | (last-guard :initform nil :accessor last-guard) |
2100b87b DG |
40 | (default-accum-var :initform nil :accessor default-accum-var) |
41 | (default-accum-kind :initform nil :accessor default-accum-kind) | |
42 | (body :initform nil :accessor body))) | |
43 | ||
44 | (defun nreverse-loop-state (state) | |
45 | (macrolet ((rev% (&rest accs) | |
46 | (cons 'progn (loop :for a :in accs :collect `(setf (,a state) (nreverse (,a state))))))) | |
5e632069 | 47 | (rev% iterations prologue initially finally during-first during-last body)) |
2100b87b DG |
48 | state) |
49 | ||
50 | (defun push-tokens (state toks) | |
51 | (setf (tokens state) (append toks (tokens state)))) | |
52 | ||
53 | (defun peek (state) | |
54 | (car (tokens state))) | |
55 | ||
56 | (defun eat (state &optional what tag) | |
57 | (case what | |
58 | (:if (when (eq (peek state) tag) | |
59 | (eat state) | |
60 | (eat state))) | |
61 | (:progn (cons 'progn (loop :collect (if (consp (peek state)) | |
62 | (eat state) | |
63 | (err "a compound form" (peek state))) | |
64 | :until (atom (peek state))))) | |
65 | (otherwise (let ((tok (pop (tokens state)))) | |
66 | (when (and (eq what :atom) (not (atom tok))) | |
67 | (err "an atom" tok)) | |
68 | tok)))) | |
69 | ||
70 | (defmacro with-local-var ((name expr state) &body body) | |
71 | (once-only (expr) | |
72 | `(let ((,name (aif (and (complex-js-expr? ,expr) (ps-gensym)) | |
73 | (progn (push (list 'var it ,expr) (prologue ,state)) | |
74 | it) | |
75 | ,expr))) | |
76 | ,@body))) | |
77 | ||
78 | (defun for-from (var state) | |
79 | (let ((start (eat state)) | |
80 | (op '+) | |
81 | (test-op nil) | |
82 | (by nil) | |
83 | (end nil)) | |
84 | (loop while (member (peek state) '(:to :below :downto :above :by)) do | |
85 | (let ((term (eat state))) | |
86 | (if (eq term :by) | |
87 | (setf by (eat state)) | |
88 | (setf op (case term ((:downto :above) '-) (otherwise '+)) | |
89 | test-op (case term (:to '>) (:below '>=) (:downto '<) (:above '<=)) | |
90 | end (eat state))))) | |
91 | (let ((test (when test-op | |
92 | (with-local-var (v end state) | |
93 | (list test-op var v))))) | |
5e632069 | 94 | (push `(,var nil ,start (,op ,var ,(or by 1)) ,test) (iterations state))))) |
2100b87b | 95 | |
5e632069 | 96 | (defun for-= (var bindings state) |
2100b87b DG |
97 | (let ((start (eat state)) |
98 | (then (eat state :if :then))) | |
5e632069 | 99 | (push (list var bindings start (or then start) nil) (iterations state)))) |
2100b87b | 100 | |
5e632069 | 101 | (defun for-in (var bindings state) |
2100b87b DG |
102 | (with-local-var (arr (eat state) state) |
103 | (let ((index (or (eat state :if :index) (ps-gensym)))) | |
104 | (push-tokens state `(,index :from 0 :below (length ,arr) | |
105 | ,var := (aref ,arr ,index))) | |
106 | (for-clause state) | |
5e632069 DG |
107 | (for-clause state) |
108 | ;; set bindings associated with original clause, e.g. "loop :for (a b) :in c" | |
109 | (setf (second (car (iterations state))) bindings)))) | |
2100b87b | 110 | |
5e632069 | 111 | (defun for-on (var bindings state) |
2100b87b DG |
112 | (with-local-var (arr (eat state) state) |
113 | (let ((by (aif (eat state :if :by) | |
114 | `(,(reduce-function-symbol it) ,var) | |
115 | `((@ ,var :slice) 1)))) | |
116 | (push-tokens state `(,var := ,arr :then ,by)) | |
117 | (for-clause state) | |
5e632069 DG |
118 | (let ((this-iteration (car (iterations state)))) |
119 | (setf (second this-iteration) bindings) | |
120 | ;; set the end-test | |
121 | (setf (fifth this-iteration) `(or (null ,var) (= (length ,var) 0))))))) | |
2100b87b DG |
122 | |
123 | (defun for-clause (state) | |
124 | (let* ((place (eat state)) | |
125 | (var (when (atom place) place)) | |
5e632069 | 126 | (bindings (unless var place)) |
2100b87b | 127 | (term (eat state :atom))) |
5e632069 | 128 | (when bindings |
2100b87b | 129 | (when (eq term :from) |
5e632069 DG |
130 | (err "an atom after FROM" bindings)) |
131 | (setf var (ps-gensym))) | |
2100b87b DG |
132 | (case term |
133 | (:from (for-from var state)) | |
5e632069 DG |
134 | (:= (for-= var bindings state)) |
135 | ((:in :across) (for-in var bindings state)) | |
136 | (:on (for-on var bindings state)) | |
2100b87b DG |
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 | ||
56ae43a5 DG |
163 | (defun first-time-clause (state) |
164 | (push (eat state :progn) (during-first state)) | |
165 | (unless (first-guard state) | |
166 | (setf (first-guard state) (ps-gensym)))) | |
167 | ||
168 | (defun last-time-clause (state) | |
169 | (push (eat state :progn) (during-last state)) | |
170 | (unless (last-guard state) | |
171 | (setf (last-guard state) (ps-gensym)))) | |
172 | ||
2100b87b DG |
173 | (defun repeat-clause (state) |
174 | (let ((index (ps-gensym))) | |
175 | (setf (tokens state) (append `(,index :from 0 :below ,(eat state)) (tokens state))) | |
176 | (for-clause state))) | |
177 | ||
178 | (defun body-clause (term state) | |
179 | (case term | |
180 | ((:when :unless) (list (intern (symbol-name term)) | |
181 | (eat state) | |
182 | (body-clause (eat state :atom) state))) | |
183 | ((:sum :collect :count :minimize :maximize) (accumulate term (eat state) (eat state :if :into) state)) | |
184 | (:do (eat state :progn)) | |
185 | (otherwise (err "a PS-LOOP keyword" term)))) | |
186 | ||
187 | (defun clause (state) | |
188 | (let ((term (eat state :atom))) | |
189 | (case term | |
190 | (:for (for-clause state)) | |
191 | (:repeat (repeat-clause state)) | |
192 | (:while (push `(unless ,(eat state) break) (body state))) | |
193 | (:until (push `(when ,(eat state) break) (body state))) | |
194 | (:initially (push (eat state :progn) (initially state))) | |
195 | (:finally (push (eat state :progn) (finally state))) | |
56ae43a5 DG |
196 | (:first-time (first-time-clause state)) |
197 | (:last-time (last-time-clause state)) | |
2100b87b DG |
198 | (otherwise (push (body-clause term state) (body state)))))) |
199 | ||
a3939827 | 200 | (defun parse-ps-loop (terms) |
2100b87b DG |
201 | (if (null terms) |
202 | (err "loop definition" nil) | |
203 | (let ((state (make-instance 'loop-state :tokens terms))) | |
204 | (loop :while (tokens state) :do (clause state)) | |
205 | (nreverse-loop-state state)))) | |
206 | ||
56ae43a5 DG |
207 | (defun multiple-fors? (loop) |
208 | (> (length (iterations loop)) 1)) | |
209 | ||
210 | (defun inits (loop) | |
5e632069 DG |
211 | (mapcar (lambda (x) (list (first x) (third x))) |
212 | (iterations loop))) | |
2100b87b | 213 | |
56ae43a5 | 214 | (defun steps (loop) |
5e632069 DG |
215 | (mapcar (lambda (x) `(setf ,(first x) ,(fourth x))) |
216 | (iterations loop))) | |
2100b87b DG |
217 | |
218 | (defun end-test (loop) | |
5e632069 | 219 | (aif (loop :for (nil nil nil nil test) :in (iterations loop) |
56ae43a5 | 220 | :when test :collect test) |
2100b87b DG |
221 | (if (cdr it) |
222 | (list 'not (cons 'or it)) | |
223 | (cons 'not it)) | |
56ae43a5 DG |
224 | t)) |
225 | ||
ab0f47a9 | 226 | (defun wrap-with-destructurings (iterations forms) |
5e632069 DG |
227 | (if (null iterations) |
228 | forms | |
ab0f47a9 | 229 | (wrap-with-destructurings |
5e632069 DG |
230 | (cdr iterations) |
231 | (aif (second (car iterations)) | |
232 | `((destructuring-bind ,it ,(first (car iterations)) ,@forms)) | |
233 | forms)))) | |
234 | ||
235 | (defun outer-body (loop) | |
ab0f47a9 | 236 | (wrap-with-destructurings |
5e632069 | 237 | (iterations loop) |
ab0f47a9 DG |
238 | (append (body loop) |
239 | (loop :for (var nil nil step test) :in (iterations loop) | |
240 | :collect `(setf ,var ,step) | |
241 | :when test :collect `(when ,test (break)))))) | |
56ae43a5 | 242 | |
5e632069 | 243 | (defun init-and-test (iterations form) |
ab0f47a9 | 244 | (loop :for (var nil init nil test) :in (reverse iterations) :do |
5e632069 DG |
245 | (when test |
246 | (setf form `(unless ,test ,form))) | |
ab0f47a9 DG |
247 | ;; (when bindings |
248 | ;; (setf form `(destructuring-bind ,bindings ,var ,form))) | |
5e632069 DG |
249 | (setf form `(let ((,var ,init)) ,form))) |
250 | form) | |
251 | ||
ab0f47a9 | 252 | (defun loop-form-with-alternating-tests (loop) |
56ae43a5 DG |
253 | (let ((form `(progn |
254 | ,@(initially loop) | |
ab0f47a9 DG |
255 | (while t |
256 | ,@(awhen (during-first loop) | |
257 | `((when ,(first-guard loop) | |
258 | ,@it | |
259 | (setf ,(first-guard loop) nil)))) | |
260 | ,@(outer-body loop) | |
261 | ,@(when (during-last loop) | |
262 | `((setf ,(last-guard loop) t)))) | |
56ae43a5 DG |
263 | ,@(awhen (during-last loop) |
264 | `((when ,(last-guard loop) ,@it))) | |
265 | ,@(finally loop)))) | |
ab0f47a9 DG |
266 | (init-and-test (iterations loop) form))) |
267 | ||
268 | (defun simple-for-form (loop) | |
269 | `(progn | |
270 | ,@(initially loop) | |
271 | (for ,(inits loop) (,(end-test loop)) ,(steps loop) | |
272 | ,@(awhen (during-first loop) | |
273 | `((when ,(first-guard loop) | |
274 | ,@it | |
275 | (setf ,(first-guard loop) nil)))) | |
276 | ,@(wrap-with-destructurings (iterations loop) (body loop)) | |
277 | ,@(when (during-last loop) | |
278 | `((setf ,(last-guard loop) t)))) | |
279 | ,@(awhen (during-last loop) | |
280 | `((when ,(last-guard loop) ,@it))) | |
281 | ,@(finally loop))) | |
e4ee1b86 DG |
282 | |
283 | (defpsmacro loop (&rest args) | |
56ae43a5 | 284 | (let ((loop (parse-ps-loop (normalize-loop-keywords args)))) |
2100b87b | 285 | `(,@(if (default-accum-var loop) '(with-lambda ()) '(progn)) |
56ae43a5 DG |
286 | ,@(when (during-first loop) `((var ,(first-guard loop) t))) |
287 | ,@(when (during-last loop) `((var ,(last-guard loop) nil))) | |
2100b87b | 288 | ,@(prologue loop) |
ab0f47a9 DG |
289 | ,(if (multiple-fors? loop) |
290 | (loop-form-with-alternating-tests loop) | |
291 | (simple-for-form loop)) | |
2100b87b | 292 | ,@(when (default-accum-var loop) `((return ,(default-accum-var loop))))))) |