1 (in-package :parenscript
)
3 (defun complex-js-expr?
(expr)
5 (or (find #\.
(symbol-name expr
))
6 (not (eq (ps-macroexpand expr
) expr
)))
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
))
14 (defun normalize-loop-keywords (args)
17 (or (find-if (lambda (key) (and (symbolp x
) (equal (symbol-name x
) (symbol-name key
))))
22 (defun reduce-function-symbol (sym)
23 (if (and (consp sym
) (eq 'function
(first sym
)))
27 (defun err (expected got
)
28 (error "PS-LOOP expected ~a, got ~a." expected got
))
30 (defclass loop-state
()
31 ((tokens :initarg
:tokens
:accessor tokens
)
32 (iterations :initform nil
:accessor iterations
)
33 (prologue :initform nil
:accessor prologue
)
34 (initially :initform nil
:accessor initially
)
35 (finally :initform nil
:accessor finally
)
36 (during-first :initform nil
:accessor during-first
)
37 (first-guard :initform nil
:accessor first-guard
)
38 (during-last :initform nil
:accessor during-last
)
39 (last-guard :initform nil
:accessor last-guard
)
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
)))
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
)))))))
47 (rev% iterations prologue initially finally during-first during-last body
))
50 (defun push-tokens (state toks
)
51 (setf (tokens state
) (append toks
(tokens state
))))
56 (defun eat (state &optional what tag
)
58 (:if
(when (eq (peek state
) tag
)
61 (:progn
(cons 'progn
(loop :collect
(if (consp (peek 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
)))
70 (defmacro with-local-var
((name expr state
) &body body
)
72 `(let ((,name
(aif (and (complex-js-expr?
,expr
) (ps-gensym))
73 (progn (push (list 'var it
,expr
) (prologue ,state
))
78 (defun for-from (var state
)
79 (let ((start (eat state
))
84 (loop while
(member (peek state
) '(:to
:below
:downto
:above
:by
)) do
85 (let ((term (eat state
)))
88 (setf op
(case term
((:downto
:above
) '-
) (otherwise '+))
89 test-op
(case term
(:to
'>) (:below
'>=) (:downto
'<) (:above
'<=))
91 (let ((test (when test-op
92 (with-local-var (v end state
)
93 (list test-op var v
)))))
94 (push `(,var nil
,start
(,op
,var
,(or by
1)) ,test
) (iterations state
)))))
96 (defun for-= (var bindings state
)
97 (let ((start (eat state
))
98 (then (eat state
:if
:then
)))
99 (push (list var bindings start
(or then start
) nil
) (iterations state
))))
101 (defun for-in (var bindings state
)
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
)))
108 ;; set bindings associated with original clause, e.g. "loop :for (a b) :in c"
109 (setf (second (car (iterations state
))) bindings
))))
111 (defun for-on (var bindings state
)
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
))
118 (let ((this-iteration (car (iterations state
))))
119 (setf (second this-iteration
) bindings
)
121 (setf (fifth this-iteration
) `(or (null ,var
) (= (length ,var
) 0)))))))
123 (defun for-clause (state)
124 (let* ((place (eat state
))
125 (var (when (atom place
) place
))
126 (bindings (unless var place
))
127 (term (eat state
:atom
)))
129 (when (eq term
:from
)
130 (err "an atom after FROM" bindings
))
131 (setf var
(ps-gensym)))
133 (:from
(for-from var state
))
134 (:= (for-= var bindings state
))
135 ((:in
:across
) (for-in var bindings state
))
136 (:on
(for-on var bindings state
))
137 (otherwise (error "FOR ~s ~s is not valid in PS-LOOP." var term
)))))
139 (defun accumulate (kind term var state
)
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
149 (setf (default-accum-kind state
) kind
))
150 (setf var
(default-accum-var state
)))
151 (let ((initial (case kind
153 ((:maximize
:minimize
) nil
)
154 (:collect
'(array)))))
155 (pushnew `(var ,var
,initial
) (prologue state
) :key
#'second
))
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
))))
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))))
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))))
173 (defun repeat-clause (state)
174 (let ((index (ps-gensym)))
175 (setf (tokens state
) (append `(,index
:from
0 :below
,(eat state
)) (tokens state
)))
178 (defun body-clause (term state
)
180 ((:when
:unless
) (list (intern (symbol-name term
))
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
))))
187 (defun clause (state)
188 (let ((term (eat state
:atom
)))
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
)))
196 (:first-time
(first-time-clause state
))
197 (:last-time
(last-time-clause state
))
198 (otherwise (push (body-clause term state
) (body state
))))))
200 (defun parse-ps-loop (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
))))
207 (defun multiple-fors?
(loop)
208 (> (length (iterations loop
)) 1))
211 (mapcar (lambda (x) (list (first x
) (third x
)))
215 (mapcar (lambda (x) `(setf ,(first x
) ,(fourth x
)))
218 (defun end-test (loop)
219 (aif (loop :for
(nil nil nil nil test
) :in
(iterations loop
)
220 :when test
:collect test
)
222 (list 'not
(cons 'or it
))
226 (defun wrap-with-dbinds (iterations forms
)
227 (if (null iterations
)
231 (aif (second (car iterations
))
232 `((destructuring-bind ,it
,(first (car iterations
)) ,@forms
))
235 (defun outer-body (loop)
238 (if (multiple-fors? loop
)
240 (loop :for
(var nil nil step test
) :in
(iterations loop
)
241 :collect
`(setf ,var
,step
)
242 :when test
:collect
`(when ,test
(break))))
245 (defun the-actual-loop (loop)
246 (let ((body `(,@(awhen (during-first loop
)
247 `((when ,(first-guard loop
)
249 (setf ,(first-guard loop
) nil
))))
251 ,@(when (during-last loop
)
252 `((setf ,(last-guard loop
) t
))))))
253 (if (multiple-fors? loop
)
255 `(for ,(inits loop
) (,(end-test loop
)) ,(steps loop
) ,@body
))))
257 (defun init-and-test (iterations form
)
258 (loop :for
(var bindings init nil test
) :in
(reverse iterations
) :do
260 (setf form
`(unless ,test
,form
)))
262 (setf form
`(destructuring-bind ,bindings
,var
,form
)))
263 (setf form
`(let ((,var
,init
)) ,form
)))
266 (defun the-loop-form (loop)
269 ,(the-actual-loop loop
)
270 ,@(awhen (during-last loop
)
271 `((when ,(last-guard loop
) ,@it
)))
273 (if (multiple-fors? loop
)
274 (init-and-test (iterations loop
) form
)
277 (defpsmacro loop
(&rest args
)
278 (let ((loop (parse-ps-loop (normalize-loop-keywords args
))))
279 `(,@(if (default-accum-var loop
) '(with-lambda ()) '(progn))
280 ,@(when (during-first loop
) `((var ,(first-guard loop
) t
)))
281 ,@(when (during-last loop
) `((var ,(last-guard loop
) nil
)))
283 ,(the-loop-form loop
)
284 ,@(when (default-accum-var loop
) `((return ,(default-accum-var loop
)))))))