1 (in-package :parenscript
)
3 (defmacro aif
(test-form then-form
&optional else-form
)
4 `(let ((it ,test-form
))
5 (if it
,then-form
,else-form
)))
7 (defmacro once-only
((&rest names
) &body body
) ;; the version from PCL
8 (let ((gensyms (loop for nil in names collect
(gensym))))
9 `(let (,@(loop for g in gensyms collect
`(,g
(gensym))))
10 `(let (,,@(loop for g in gensyms for n in names collect
``(,,g
,,n
)))
11 ,(let (,@(loop for n in names for g in gensyms collect
`(,n
,g
)))
14 (defun complex-js-expr?
(expr)
16 (find #\.
(symbol-name expr
))
19 (defvar *loop-clauses
* '(:for
:do
:when
:unless
:initially
:finally
:first-time
:last-time
:while
:until
))
20 (defvar *loop-keywords
*
21 (append *loop-clauses
* '(:from
:to
:below
:downto
:above
:by
:in
:across
:index
:= :then
:sum
:into
)))
23 (defun normalize-loop-keywords (args)
25 (or (find-if (lambda (key) (eq x
(intern (string key
))))
30 (defun parse-js-loop (terms)
32 init-step-forms end-test-forms
36 (macrolet ((with-local-var ((name expr
) &body body
)
38 `(let ((,name
(aif (and (complex-js-expr?
,expr
) (ps-gensym))
39 (progn (push (list 'var it
,expr
) prologue
)
48 (error "JS-LOOP expected ~s, got ~s." expected got
))
49 (consume (&optional what
)
50 (let ((term (pop terms
)))
51 (when (and what
(not (eq what term
)))
57 (err "an atom" (next))))
59 (cons 'progn
(loop :collect
(if (consp (next))
61 (err "a compound form" (next)))
62 :until
(atom (next)))))
69 ((:when
:unless
) (list (intern (symbol-name term
))
71 (body-clause (consume-atom))))
72 (:sum
(let ((sum-expr (consume)))
74 (let ((sum-var (consume-atom)))
75 (push `(var ,sum-var
0) prologue
)
76 `(incf ,sum-var
,sum-expr
))))
78 (otherwise (err "a JS-LOOP keyword" term
))))
80 (let ((start (consume))
85 (loop while
(member (next) '(:to
:below
:downto
:above
:by
)) do
86 (let ((term (consume)))
89 (setf op
(case term
((:downto
:above
) '-
) (otherwise '+))
90 test
(case term
(:to
'>) (:below
'>=) (:downto
'<) (:above
'<=))
92 (push `(,var
,start
(,op
,var
,(or by
1))) init-step-forms
)
94 (with-local-var (end-var end
)
95 (push (list test var end-var
) end-test-forms
)))))
97 (let ((start (consume))
98 (then (consume-if :then
)))
99 (push (list var start
(or then start
)) init-step-forms
)))
101 (with-local-var (arr (consume))
102 (let* ((index (or (consume-if :index
) (ps-gensym)))
103 (equiv `(:for
,index
:from
0 :below
(length ,arr
)
104 :for
,var
:= (aref ,arr
,index
))))
105 (setf terms
(append equiv terms
))
109 (let ((var (consume-atom))
110 (term (consume-atom)))
112 (:from
(for-from var
))
114 ((:in
:across
) (for-in var
))
115 (otherwise (error "FOR ~s ~s is not valid in JS-LOOP." var term
)))))
117 (let ((term (consume-atom)))
120 (:while
(push `(unless ,(consume) break
) body
))
121 (:until
(push `(when ,(consume) break
) body
))
122 (:initially
(push (consume-progn) initially
))
123 (:finally
(push (consume-progn) finally
))
124 (:first-time
(push (consume-progn) first-time
))
125 (:last-time
(push (consume-progn) last-time
))
126 (otherwise (push (body-clause term
) body
))))))
128 (loop :while terms
:do
(clause))
129 (err "loop definition" nil
))
130 (values (nreverse prologue
)
131 (nreverse init-step-forms
)
132 (aif (nreverse end-test-forms
)
139 (nreverse first-time
)
143 (defpsmacro loop
(&rest args
)
144 (multiple-value-bind (prologue
145 init-step-forms end-test-forms
149 (parse-js-loop (normalize-loop-keywords args
))
150 (let ((first-guard (and first-time
(ps-gensym)))
151 (last-guard (and last-time
(ps-gensym))))
152 `(progn ,@(when first-time
`((var ,first-guard t
)))
153 ,@(when last-time
`((var ,last-guard nil
)))
161 (setf ,first-guard nil
))))
164 `((setf ,last-guard t
))))
165 ,@(when last-time
`((when ,last-guard
,@last-time
)))