1 (in-package :parenscript
)
3 (defun complex-js-expr?
(expr)
5 (find #\.
(symbol-name expr
))
8 (defvar *loop-clauses
* '(:for
:do
:when
:unless
:initially
:finally
:first-time
:last-time
:while
:until
))
9 (defvar *loop-keywords
*
10 (append *loop-clauses
* '(:from
:to
:below
:downto
:above
:by
:in
:across
:index
:= :then
:sum
:into
)))
12 (defun normalize-loop-keywords (args)
14 (or (find-if (lambda (key) (eq x
(intern (string key
))))
19 (defun parse-js-loop (terms)
21 init-step-forms end-test-forms
25 (macrolet ((with-local-var ((name expr
) &body body
)
27 `(let ((,name
(aif (and (complex-js-expr?
,expr
) (ps-gensym))
28 (progn (push (list 'var it
,expr
) prologue
)
37 (error "JS-LOOP expected ~s, got ~s." expected got
))
38 (consume (&optional what
)
39 (let ((term (pop terms
)))
40 (when (and what
(not (eq what term
)))
46 (err "an atom" (next))))
48 (cons 'progn
(loop :collect
(if (consp (next))
50 (err "a compound form" (next)))
51 :until
(atom (next)))))
58 ((:when
:unless
) (list (intern (symbol-name term
))
60 (body-clause (consume-atom))))
61 (:sum
(let ((sum-expr (consume)))
63 (let ((sum-var (consume-atom)))
64 (push `(var ,sum-var
0) prologue
)
65 `(incf ,sum-var
,sum-expr
))))
67 (otherwise (err "a JS-LOOP keyword" term
))))
69 (let ((start (consume))
74 (loop while
(member (next) '(:to
:below
:downto
:above
:by
)) do
75 (let ((term (consume)))
78 (setf op
(case term
((:downto
:above
) '-
) (otherwise '+))
79 test
(case term
(:to
'>) (:below
'>=) (:downto
'<) (:above
'<=))
81 (push `(,var
,start
(,op
,var
,(or by
1))) init-step-forms
)
83 (with-local-var (end-var end
)
84 (push (list test var end-var
) end-test-forms
)))))
86 (let ((start (consume))
87 (then (consume-if :then
)))
88 (push (list var start
(or then start
)) init-step-forms
)))
90 (with-local-var (arr (consume))
91 (let* ((index (or (consume-if :index
) (ps-gensym)))
92 (equiv `(:for
,index
:from
0 :below
(length ,arr
)
93 :for
,var
:= (aref ,arr
,index
))))
94 (setf terms
(append equiv terms
))
98 (let ((var (consume-atom))
99 (term (consume-atom)))
101 (:from
(for-from var
))
103 ((:in
:across
) (for-in var
))
104 (otherwise (error "FOR ~s ~s is not valid in JS-LOOP." var term
)))))
106 (let ((term (consume-atom)))
109 (:while
(push `(unless ,(consume) break
) body
))
110 (:until
(push `(when ,(consume) break
) body
))
111 (:initially
(push (consume-progn) initially
))
112 (:finally
(push (consume-progn) finally
))
113 (:first-time
(push (consume-progn) first-time
))
114 (:last-time
(push (consume-progn) last-time
))
115 (otherwise (push (body-clause term
) body
))))))
117 (loop :while terms
:do
(clause))
118 (err "loop definition" nil
))
119 (values (nreverse prologue
)
120 (nreverse init-step-forms
)
121 (aif (nreverse end-test-forms
)
128 (nreverse first-time
)
132 (defpsmacro loop
(&rest args
)
133 (multiple-value-bind (prologue
134 init-step-forms end-test-forms
138 (parse-js-loop (normalize-loop-keywords args
))
139 (let ((first-guard (and first-time
(ps-gensym)))
140 (last-guard (and last-time
(ps-gensym))))
141 `(progn ,@(when first-time
`((var ,first-guard t
)))
142 ,@(when last-time
`((var ,last-guard nil
)))
145 (do* ,init-step-forms
150 (setf ,first-guard nil
))))
153 `((setf ,last-guard t
))))
154 ,@(when last-time
`((when ,last-guard
,@last-time
)))