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 (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
)))
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
)))
53 (defun push-tokens (state toks
)
54 (setf (tokens state
) (append toks
(tokens state
))))
59 (defun eat (state &optional what tag
)
61 (:if
(when (eq (peek state
) tag
)
64 (:progn
(cons 'progn
(loop :collect
(if (consp (peek 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
)))
73 (defmacro with-local-var
((name expr state
) &body body
)
75 `(let ((,name
(aif (and (complex-js-expr?
,expr
) (ps-gensym))
76 (progn (push (list 'var it
,expr
) (prologue ,state
))
81 (defun for-from (var state
)
82 (let ((start (eat state
))
87 (loop while
(member (peek state
) '(:to
:below
:downto
:above
:by
)) do
88 (let ((term (eat state
)))
91 (setf op
(case term
((:downto
:above
) '-
) (otherwise '+))
92 test-op
(case term
(:to
'>) (:below
'>=) (:downto
'<) (:above
'<=))
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
)))))
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
))))
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
)))
110 (for-clause state
))))
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
))
120 (setf (fourth (car (iterations state
))) `(or (null ,var
) (= (length ,var
) 0))))))
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
)))
128 (when (eq term
:from
)
129 (err "an atom after FROM" varlist
))
130 (setf var
(ps-gensym))
131 (push (list varlist var
) (destructurings state
)))
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
)))))
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 repeat-clause (state)
164 (let ((index (ps-gensym)))
165 (setf (tokens state
) (append `(,index
:from
0 :below
,(eat state
)) (tokens state
)))
168 (defun body-clause (term state
)
170 ((:when
:unless
) (list (intern (symbol-name term
))
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
))))
177 (defun clause (state)
178 (let ((term (eat state
:atom
)))
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
))))))
190 (defun parse-ps-loop (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
))))
197 (defun init-forms (loop)
198 (mapcar (lambda (x) (subseq x
0 2)) (iterations loop
)))
200 (defun step-forms (loop)
201 (mapcar (lambda (x) `(setf ,(first x
) ,(third x
))) (iterations loop
)))
203 (defun end-test (loop)
204 (aif (loop :for
(nil nil nil test
) :in
(iterations loop
) :when test
:collect test
)
206 (list 'not
(cons 'or it
))
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
)))
219 (for ,(init-forms loop
)
222 ,@(when (during-first loop
)
224 ,@(during-first loop
)
225 (setf ,first-guard nil
))))
227 ,@(when (during-last loop
)
228 `((setf ,last-guard t
))))
229 ,@(when (during-last loop
)
230 `((when ,last-guard
,@(during-last loop
))))
232 ,@(when (default-accum-var loop
) `((return ,(default-accum-var loop
)))))))