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 (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 (first-guard :initform nil
:accessor first-guard
)
39 (during-last :initform nil
:accessor during-last
)
40 (last-guard :initform nil
:accessor last-guard
)
41 (default-accum-var :initform nil
:accessor default-accum-var
)
42 (default-accum-kind :initform nil
:accessor default-accum-kind
)
43 (body :initform nil
:accessor body
)))
45 (defun nreverse-loop-state (state)
46 (macrolet ((rev%
(&rest accs
)
47 (cons 'progn
(loop :for a
:in accs
:collect
`(setf (,a state
) (nreverse (,a state
)))))))
48 (rev% iterations prologue initially finally during-first during-last
)
49 (let ((body (nreverse (body state
))))
50 (loop :for
(list var
) :in
(destructurings state
) :do
51 (setf body
`((destructuring-bind ,list
,var
,@body
))))
52 (setf (body state
) body
)))
55 (defun push-tokens (state toks
)
56 (setf (tokens state
) (append toks
(tokens state
))))
61 (defun eat (state &optional what tag
)
63 (:if
(when (eq (peek state
) tag
)
66 (:progn
(cons 'progn
(loop :collect
(if (consp (peek state
))
68 (err "a compound form" (peek state
)))
69 :until
(atom (peek state
)))))
70 (otherwise (let ((tok (pop (tokens state
))))
71 (when (and (eq what
:atom
) (not (atom tok
)))
75 (defmacro with-local-var
((name expr state
) &body body
)
77 `(let ((,name
(aif (and (complex-js-expr?
,expr
) (ps-gensym))
78 (progn (push (list 'var it
,expr
) (prologue ,state
))
83 (defun for-from (var state
)
84 (let ((start (eat state
))
89 (loop while
(member (peek state
) '(:to
:below
:downto
:above
:by
)) do
90 (let ((term (eat state
)))
93 (setf op
(case term
((:downto
:above
) '-
) (otherwise '+))
94 test-op
(case term
(:to
'>) (:below
'>=) (:downto
'<) (:above
'<=))
96 (let ((test (when test-op
97 (with-local-var (v end state
)
98 (list test-op var v
)))))
99 (push `(,var
,start
(,op
,var
,(or by
1)) ,test
) (iterations state
)))))
101 (defun for-= (var state
)
102 (let ((start (eat state
))
103 (then (eat state
:if
:then
)))
104 (push (list var start
(or then start
) nil
) (iterations state
))))
106 (defun for-in (var state
)
107 (with-local-var (arr (eat state
) state
)
108 (let ((index (or (eat state
:if
:index
) (ps-gensym))))
109 (push-tokens state
`(,index
:from
0 :below
(length ,arr
)
110 ,var
:= (aref ,arr
,index
)))
112 (for-clause state
))))
114 (defun for-on (var state
)
115 (with-local-var (arr (eat state
) state
)
116 (let ((by (aif (eat state
:if
:by
)
117 `(,(reduce-function-symbol it
) ,var
)
118 `((@ ,var
:slice
) 1))))
119 (push-tokens state
`(,var
:= ,arr
:then
,by
))
122 (setf (fourth (car (iterations state
))) `(or (null ,var
) (= (length ,var
) 0))))))
124 (defun for-clause (state)
125 (let* ((place (eat state
))
126 (var (when (atom place
) place
))
127 (varlist (unless var place
))
128 (term (eat state
:atom
)))
130 (when (eq term
:from
)
131 (err "an atom after FROM" varlist
))
132 (setf var
(ps-gensym))
133 (push (list varlist var
) (destructurings state
)))
135 (:from
(for-from var state
))
136 (:= (for-= var state
))
137 ((:in
:across
) (for-in var state
))
138 (:on
(for-on var state
))
139 (otherwise (error "FOR ~s ~s is not valid in PS-LOOP." var term
)))))
141 (defun accumulate (kind term var state
)
143 (when (and (default-accum-kind state
) (not (eq kind
(default-accum-kind state
))))
144 (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
)))
145 (unless (default-accum-var state
)
146 (setf (default-accum-var state
)
147 (ps-gensym (case kind
151 (setf (default-accum-kind state
) kind
))
152 (setf var
(default-accum-var state
)))
153 (let ((initial (case kind
155 ((:maximize
:minimize
) nil
)
156 (:collect
'(array)))))
157 (pushnew `(var ,var
,initial
) (prologue state
) :key
#'second
))
159 (:sum
`(incf ,var
,term
))
160 (:count
`(unless (null ,term
) (incf ,var
)))
161 (:minimize
`(setf ,var
(if (null ,var
) ,term
(min ,var
,term
))))
162 (:maximize
`(setf ,var
(if (null ,var
) ,term
(max ,var
,term
))))
163 (:collect
`((@ ,var
:push
) ,term
))))
165 (defun first-time-clause (state)
166 (push (eat state
:progn
) (during-first state
))
167 (unless (first-guard state
)
168 (setf (first-guard state
) (ps-gensym))))
170 (defun last-time-clause (state)
171 (push (eat state
:progn
) (during-last state
))
172 (unless (last-guard state
)
173 (setf (last-guard state
) (ps-gensym))))
175 (defun repeat-clause (state)
176 (let ((index (ps-gensym)))
177 (setf (tokens state
) (append `(,index
:from
0 :below
,(eat state
)) (tokens state
)))
180 (defun body-clause (term state
)
182 ((:when
:unless
) (list (intern (symbol-name term
))
184 (body-clause (eat state
:atom
) state
)))
185 ((:sum
:collect
:count
:minimize
:maximize
) (accumulate term
(eat state
) (eat state
:if
:into
) state
))
186 (:do
(eat state
:progn
))
187 (otherwise (err "a PS-LOOP keyword" term
))))
189 (defun clause (state)
190 (let ((term (eat state
:atom
)))
192 (:for
(for-clause state
))
193 (:repeat
(repeat-clause state
))
194 (:while
(push `(unless ,(eat state
) break
) (body state
)))
195 (:until
(push `(when ,(eat state
) break
) (body state
)))
196 (:initially
(push (eat state
:progn
) (initially state
)))
197 (:finally
(push (eat state
:progn
) (finally state
)))
198 (:first-time
(first-time-clause state
))
199 (:last-time
(last-time-clause state
))
200 (otherwise (push (body-clause term state
) (body state
))))))
202 (defun parse-ps-loop (terms)
204 (err "loop definition" nil
)
205 (let ((state (make-instance 'loop-state
:tokens terms
)))
206 (loop :while
(tokens state
) :do
(clause state
))
207 (nreverse-loop-state state
))))
209 (defun multiple-fors?
(loop)
210 (> (length (iterations loop
)) 1))
213 (mapcar (lambda (x) (subseq x
0 2)) (iterations loop
)))
216 (mapcar (lambda (x) `(setf ,(first x
) ,(third x
))) (iterations loop
)))
218 (defun end-test (loop)
219 (aif (loop :for
(nil nil nil test
) :in
(iterations loop
)
220 :when test
:collect test
)
222 (list 'not
(cons 'or it
))
226 (defun inner-body (loop)
227 (if (multiple-fors? loop
)
229 (loop :for
(var nil step test
) :in
(iterations loop
)
230 :collect
`(setf ,var
,step
)
231 :when test
:collect
`(when ,test
(break))))
234 (defun the-actual-loop (loop)
235 (let ((body `(,@(awhen (during-first loop
)
236 `((when ,(first-guard loop
)
238 (setf ,(first-guard loop
) nil
))))
240 ,@(when (during-last loop
)
241 `((setf ,(last-guard loop
) t
))))))
242 (if (multiple-fors? loop
)
244 `(for ,(inits loop
) (,(end-test loop
)) ,(steps loop
) ,@body
))))
246 (defun the-loop-form (loop)
249 ,(the-actual-loop loop
)
250 ,@(awhen (during-last loop
)
251 `((when ,(last-guard loop
) ,@it
)))
253 (when (multiple-fors? loop
)
254 (loop :for
(var init nil test
) :in
(reverse (iterations loop
))
255 :when test
:do
(setf form
`(unless ,test
,form
))
256 :do
(setf form
`(let ((,var
,init
)) ,form
))))
259 (defpsmacro loop
(&rest args
)
260 (let ((loop (parse-ps-loop (normalize-loop-keywords args
))))
261 `(,@(if (default-accum-var loop
) '(with-lambda ()) '(progn))
262 ,@(when (during-first loop
) `((var ,(first-guard loop
) t
)))
263 ,@(when (during-last loop
) `((var ,(last-guard loop
) nil
)))
265 ,(the-loop-form loop
)
266 ,@(when (default-accum-var loop
) `((return ,(default-accum-var loop
)))))))