Added Scott Bell's implementation of ASH.
[parenscript.git] / src / special-operators.lisp
blob9ecf3fbd770bce66a1f8b9f5d78f8d408d8063e8
1 (in-package #:parenscript)
3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4 ;;; arithmetic and logic
6 (define-trivial-special-ops
7 + ps-js:+
8 - ps-js:-
9 * ps-js:*
10 / ps-js:/
11 rem ps-js:%
12 and ps-js:&&
13 or ps-js:\|\|
15 logand ps-js:&
16 logior ps-js:\|
17 logxor ps-js:^
18 lognot ps-js:~
19 ;; << and >> are not exported, but for use by ash macro
20 << ps-js:<<
21 >> ps-js:>>
23 throw ps-js:throw
24 aref ps-js:aref
26 funcall ps-js:funcall
29 (define-expression-operator - (&rest args)
30 (let ((args (mapcar #'compile-expression args)))
31 (cons (if (cdr args) 'ps-js:- 'ps-js:negate) args)))
33 (defun fix-nary-comparison (operator objects)
34 (let* ((tmp-var-forms (butlast (cdr objects)))
35 (tmp-vars (loop repeat (length tmp-var-forms)
36 collect (ps-gensym "_CMP")))
37 (all-comparisons (append (list (car objects))
38 tmp-vars
39 (last objects))))
40 `(let ,(mapcar #'list tmp-vars tmp-var-forms)
41 (and ,@(loop for x1 in all-comparisons
42 for x2 in (cdr all-comparisons)
43 collect (list operator x1 x2))))))
45 (macrolet ((define-nary-comparison-forms (&rest mappings)
46 `(progn
47 ,@(loop for (form js-primitive) on mappings by #'cddr collect
48 `(define-expression-operator ,form (&rest objects)
49 (if (cddr objects)
50 (ps-compile
51 (fix-nary-comparison ',form objects))
52 (cons ',js-primitive
53 (mapcar #'compile-expression objects))))))))
54 (define-nary-comparison-forms
55 < ps-js:<
56 > ps-js:>
57 <= ps-js:<=
58 >= ps-js:>=
59 eql ps-js:===
60 equal ps-js:==))
62 (define-expression-operator /= (a b)
63 ;; for n>2, /= is finding duplicates in an array of numbers (ie -
64 ;; nontrivial runtime algorithm), so we restrict it to binary in PS
65 `(ps-js:!== ,(compile-expression a) ,(compile-expression b)))
67 (define-expression-operator incf (x &optional (delta 1))
68 (let ((delta (ps-macroexpand delta)))
69 (if (eql delta 1)
70 `(ps-js:++ ,(compile-expression x))
71 `(ps-js:+= ,(compile-expression x) ,(compile-expression delta)))))
73 (define-expression-operator decf (x &optional (delta 1))
74 (let ((delta (ps-macroexpand delta)))
75 (if (eql delta 1)
76 `(ps-js:-- ,(compile-expression x))
77 `(ps-js:-= ,(compile-expression x) ,(compile-expression delta)))))
79 (let ((inverses (mapcan (lambda (x)
80 (list x (reverse x)))
81 '((ps-js:=== ps-js:!==)
82 (ps-js:== ps-js:!=)
83 (ps-js:< ps-js:>=)
84 (ps-js:> ps-js:<=)))))
85 (define-expression-operator not (x)
86 (let ((form (compile-expression x)))
87 (acond ((and (listp form) (eq (car form) 'ps-js:!))
88 (second form))
89 ((and (listp form) (cadr (assoc (car form) inverses)))
90 `(,it ,@(cdr form)))
91 (t `(ps-js:! ,form))))))
93 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
94 ;;; blocks and control flow
96 (defun compile-progn (body)
97 (labels ((flatten-blocks (body)
98 (when body
99 (if (and (listp (car body)) (eq 'ps-js:block (caar body)))
100 (append (cdr (car body)) (flatten-blocks (cdr body)))
101 (cons (car body) (flatten-blocks (cdr body)))))))
102 (let ((block (flatten-blocks (remove nil (mapcar #'ps-compile body)))))
103 (append (remove-if #'constantp (butlast block))
104 (unless (and (eq *compilation-level* :toplevel)
105 (not (car (last block))))
106 (last block))))))
108 (define-expression-operator progn (&rest body)
109 (if (cdr body)
110 `(ps-js:|,| ,@(compile-progn body))
111 (compile-expression (car body))))
113 (define-statement-operator progn (&rest body)
114 `(ps-js:block ,@(compile-progn body)))
116 (defun wrap-block-for-dynamic-return (tag body)
117 (if (member tag *tags-that-return-throws-to*)
118 `(ps-js:block
119 (ps-js:try ,body
120 :catch (err ,(compile-statement `(progn (if (and err (eql ',tag (getprop err :ps-block-tag)))
121 ;; FIXME make this a multiple-value return
122 (getprop err :ps-return-value)
123 (throw err)))))
124 :finally nil))
125 body))
127 (define-statement-operator block (name &rest body)
128 (let* ((name (or name 'nilBlock))
129 (*lexical-extent-return-tags* (cons name *lexical-extent-return-tags*))
130 (*tags-that-return-throws-to* ()))
131 `(ps-js:label ,name ,(wrap-block-for-dynamic-return name (compile-statement `(progn ,@body))))))
133 (defun nesting-depth (form)
134 (if (consp form)
135 (max (1+ (nesting-depth (car form))) (nesting-depth (cdr form)))
138 (define-statement-operator return-from (tag &optional result)
139 (if (not tag)
140 (if in-loop-scope?
141 (progn
142 (when result
143 (warn "Trying to (RETURN ~A) from inside a loop with an implicit nil block (DO, DOLIST, DOTIMES, etc.). Parenscript doesn't support returning values this way from inside a loop yet!" result))
144 '(ps-js:break))
145 (ps-compile `(return-from nilBlock ,result)))
146 (let ((form (ps-macroexpand result)))
147 (flet ((return-exp (value) ;; this stuff needs to be fixed to handle multiple-value returns, too
148 (let ((value (compile-expression value)))
149 (cond ((or (eql '%function-body tag) (eql *function-block-name* tag))
150 `(ps-js:return ,value))
151 ((member tag *lexical-extent-return-tags*)
152 (when result
153 (warn "Trying to (RETURN-FROM ~A ~A) a value from a block. Parenscript doesn't support returning values this way from blocks yet!" tag result))
154 `(ps-js:break ,tag))
155 ((member tag *dynamic-extent-return-tags*)
156 (push tag *tags-that-return-throws-to*)
157 (ps-compile `(throw (create :ps-block-tag ',tag :ps-return-value ,value))))
158 (t (warn "Returning from unknown block ~A" tag)
159 `(ps-js:return ,value)))))) ;; for backwards-compatibility
160 (if (listp form)
161 (block expressionize
162 (ps-compile
163 (case (car form)
164 (progn
165 `(progn ,@(butlast (cdr form)) (return-from ,tag ,(car (last (cdr form))))))
166 (switch
167 `(switch ,(second form)
168 ,@(loop for (cvalue . cbody) in (cddr form)
169 for remaining on (cddr form) collect
170 (let ((last-n (cond ((or (eq 'default cvalue) (not (cdr remaining)))
172 ((eq 'break (car (last cbody)))
173 2))))
174 (if last-n
175 (let ((result-form (car (last cbody last-n))))
176 `(,cvalue
177 ,@(butlast cbody last-n)
178 (return-from ,tag ,result-form)
179 ,@(when (and (= last-n 2) (member 'if (flatten result-form))) '(break))))
180 (cons cvalue cbody))))))
181 (try
182 `(try (return-from ,tag ,(second form))
183 ,@(let ((catch (cdr (assoc :catch (cdr form))))
184 (finally (assoc :finally (cdr form))))
185 (list (when catch
186 `(:catch ,(car catch)
187 ,@(butlast (cdr catch))
188 (return-from ,tag ,(car (last (cdr catch))))))
189 finally))))
190 (cond
191 `(cond ,@(loop for clause in (cdr form) collect
192 `(,@(butlast clause)
193 (return-from ,tag ,(car (last clause)))))))
194 ((with label let flet labels macrolet symbol-macrolet) ;; implicit progn forms
195 `(,(first form) ,(second form)
196 ,@(butlast (cddr form))
197 (return-from ,tag ,(car (last (cddr form))))))
198 ((continue break throw) ;; non-local exit
199 form)
200 (return-from ;; this will go away someday
201 (unless tag
202 (warn 'simple-style-warning
203 :format-control "Trying to RETURN a RETURN without a block tag specified. Perhaps you're still returning values from functions by hand? Parenscript now implements implicit return, update your code! Things like (lambda () (return x)) are not valid Common Lisp and may not be supported in future versions of Parenscript."))
204 form)
206 (aif (and (<= (nesting-depth form) 3) (handler-case (compile-expression form) (compile-expression-error () nil)))
207 (return-from expressionize `(ps-js:return ,it))
208 `(if ,(second form)
209 (return-from ,tag ,(third form))
210 ,@(when (fourth form) `((return-from ,tag ,(fourth form)))))))
211 (otherwise
212 (if (gethash (car form) *special-statement-operators*)
213 form ;; by now only special forms that return nil should be left, so this is ok for implicit return
214 (return-from expressionize (return-exp form)))))))
215 (return-exp form))))))
217 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
218 ;;; conditionals
220 (define-expression-operator if (test then &optional else)
221 `(ps-js:? ,(compile-expression test) ,(compile-expression then) ,(compile-expression else)))
223 (define-statement-operator if (test then &optional else)
224 `(ps-js:if ,(compile-expression test)
225 ,(compile-statement `(progn ,then))
226 ,@(when else `(:else ,(compile-statement `(progn ,else))))))
228 (define-expression-operator cond (&rest clauses)
229 (compile-expression
230 (when clauses
231 (destructuring-bind (test &rest body) (car clauses)
232 (if (eq t test)
233 `(progn ,@body)
234 `(if ,test
235 (progn ,@body)
236 (cond ,@(cdr clauses))))))))
238 (define-statement-operator cond (&rest clauses)
239 `(ps-js:if ,(compile-expression (caar clauses))
240 ,(compile-statement `(progn ,@(cdar clauses)))
241 ,@(loop for (test . body) in (cdr clauses) appending
242 (if (eq t test)
243 `(:else ,(compile-statement `(progn ,@body)))
244 `(:else-if ,(compile-expression test)
245 ,(compile-statement `(progn ,@body)))))))
247 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
248 ;;; function
250 (defmacro with-declaration-effects (body-var &body body)
251 `(let* ((local-specials (when (and (listp (car ,body-var))
252 (eq (caar ,body-var) 'declare))
253 (cdr (find 'special (cdar ,body-var) :key #'car))))
254 (,body-var (if local-specials
255 (cdr ,body-var)
256 ,body-var))
257 (*special-variables* (append local-specials *special-variables*)))
258 ,@body))
260 (defun compile-function-definition (args body)
261 (with-declaration-effects body
262 (let* ((*enclosing-lexical-block-declarations* ())
263 (*enclosing-lexicals* (append args *enclosing-lexicals*))
264 (body (let ((in-loop-scope? nil)
265 (*loop-scope-lexicals* ())
266 (*loop-scope-lexicals-captured* ()))
267 (compile-statement `(return-from %function-body (progn ,@body)))))
268 (var-decls (compile-statement
269 `(progn ,@(mapcar (lambda (var) `(var ,var))
270 (remove-duplicates *enclosing-lexical-block-declarations*))))))
271 (when in-loop-scope? ;; this is probably broken when it comes to let-renaming
272 (setf *loop-scope-lexicals-captured* (append (intersection (flatten body) *loop-scope-lexicals*)
273 *loop-scope-lexicals-captured*)))
274 `(ps-js:block ,@(cdr var-decls) ,@(cdr body)))))
276 (define-expression-operator %js-lambda (args &rest body)
277 (let ((*function-block-name* nil)
278 (*dynamic-extent-return-tags* (append (when *function-block-name* (list *function-block-name*))
279 *lexical-extent-return-tags*
280 *dynamic-extent-return-tags*))
281 (*lexical-extent-return-tags* ()))
282 `(ps-js:lambda ,args ,(compile-function-definition args body))))
284 (define-statement-operator %js-defun (name args &rest body)
285 (let ((docstring (and (cdr body) (stringp (car body)) (car body)))
286 (*enclosing-lexicals* (cons name *enclosing-lexicals*))
287 (*function-block-name* name)
288 (*lexical-extent-return-tags* ())
289 (*dynamic-extent-return-tags* ())
290 (*tags-that-return-throws-to* ()))
291 `(ps-js:defun ,name ,args ,docstring
292 ,(wrap-block-for-dynamic-return name (compile-function-definition args (if docstring (cdr body) body))))))
294 (defun parse-key-spec (key-spec)
295 "parses an &key parameter. Returns 5 values:
296 var, init-form, keyword-name, supplied-p-var, init-form-supplied-p.
298 Syntax of key spec:
299 [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}*
301 (let* ((var (cond ((symbolp key-spec) key-spec)
302 ((and (listp key-spec) (symbolp (first key-spec))) (first key-spec))
303 ((and (listp key-spec) (listp (first key-spec))) (second (first key-spec)))))
304 (keyword-name (if (and (listp key-spec) (listp (first key-spec)))
305 (first (first key-spec))
306 (intern (string var) :keyword)))
307 (init-form (if (listp key-spec) (second key-spec) nil))
308 (init-form-supplied-p (if (listp key-spec) t nil))
309 (supplied-p-var (if (listp key-spec) (third key-spec) nil)))
310 (values var init-form keyword-name supplied-p-var init-form-supplied-p)))
312 (defun parse-optional-spec (spec)
313 "Parses an &optional parameter. Returns 3 values: var, init-form, supplied-p-var.
314 [&optional {var | (var [init-form [supplied-p-parameter]])}*] "
315 (let* ((var (cond ((symbolp spec) spec)
316 ((and (listp spec) (first spec)))))
317 (init-form (if (listp spec) (second spec)))
318 (supplied-p-var (if (listp spec) (third spec))))
319 (values var init-form supplied-p-var)))
321 (defun parse-extended-function (lambda-list body)
322 ;; The lambda list is transformed as follows:
324 ;; * standard and optional variables are the mapped directly into
325 ;; the js-lambda list
327 ;; * keyword variables are not included in the js-lambda list, but
328 ;; instead are obtained from the magic js ARGUMENTS
329 ;; pseudo-array. Code assigning values to keyword vars is
330 ;; prepended to the body of the function.
331 (multiple-value-bind (requireds optionals rest? rest keys? keys allow? aux?
332 aux more? more-context more-count key-object)
333 (parse-lambda-list lambda-list)
334 (declare (ignore allow? aux? aux more? more-context more-count key-object))
335 (let* ( ;; optionals are of form (var default-value)
336 (effective-args
337 (remove-if #'null
338 (append requireds
339 (mapcar #'parse-optional-spec optionals))))
340 (opt-forms
341 (mapcar (lambda (opt-spec)
342 (multiple-value-bind (name value suppl)
343 (parse-optional-spec opt-spec)
344 (if suppl
345 `(progn
346 (var ,suppl (not (eql ,name undefined)))
347 ,@(when value
348 `((when (not ,suppl) (setf ,name ,value)))))
349 (when value
350 `(when (eql ,name undefined)
351 (setf ,name ,value))))))
352 optionals))
353 (key-forms
354 (when keys?
355 (with-ps-gensyms (n)
356 (let ((decls ())
357 (assigns ()))
358 (mapc
359 (lambda (k)
360 (multiple-value-bind (var init-form keyword-str suppl)
361 (parse-key-spec k)
362 (push `(var ,var ,init-form) decls)
363 (when suppl (push `(var ,suppl nil) decls))
364 (push `(,keyword-str
365 (setf ,var (aref arguments (1+ ,n))
366 ,@(when suppl `(,suppl t))))
367 assigns)))
368 (reverse keys))
369 `(,@decls
370 (loop for ,n from ,(length requireds)
371 below (length arguments) by 2 do
372 (case (aref arguments ,n) ,@assigns)))))))
373 (rest-form
374 (when rest?
375 (with-ps-gensyms (i)
376 `(progn (var ,rest (array))
377 (dotimes (,i (- (getprop arguments 'length)
378 ,(length effective-args)))
379 (setf (aref ,rest
381 (aref arguments
382 (+ ,i ,(length effective-args)))))))))
383 (docstring (when (stringp (first body)) (first body)))
384 (body-paren-forms (if docstring (rest body) body))
385 (effective-body (append (when docstring (list docstring))
386 opt-forms
387 key-forms
388 (awhen rest-form (list it))
389 body-paren-forms)))
390 (values effective-args effective-body))))
392 (defun maybe-rename-local-function (fun-name)
393 (aif (getf *local-function-names* fun-name)
395 fun-name))
397 (defun collect-function-names (fn-defs)
398 (loop for (fn-name) in fn-defs
399 collect fn-name
400 collect (if (or (member fn-name *enclosing-lexicals*) (lookup-macro-def fn-name *symbol-macro-env*))
401 (ps-gensym (string fn-name))
402 fn-name)))
404 (define-expression-operator flet (fn-defs &rest body)
405 (let* ((fn-renames (collect-function-names fn-defs))
406 ;; the function definitions need to be compiled with previous lexical bindings
407 (fn-defs (loop for (fn-name . (args . body)) in fn-defs collect
408 (progn (when compile-expression?
409 (push (getf fn-renames fn-name) *enclosing-lexical-block-declarations*))
410 `(,(if compile-expression? 'ps-js:= 'ps-js:var)
411 ,(getf fn-renames fn-name)
412 (ps-js:lambda ,args
413 ,(let ((*function-block-name* fn-name))
414 (compile-function-definition args body)))))))
415 ;; the flet body needs to be compiled with the extended lexical environment
416 (*enclosing-lexicals* (append fn-renames *enclosing-lexicals*))
417 (*loop-scope-lexicals* (when in-loop-scope? (append fn-renames *loop-scope-lexicals*)))
418 (*local-function-names* (append fn-renames *local-function-names*)))
419 `(,(if compile-expression? 'ps-js:|,| 'ps-js:block)
420 ,@fn-defs
421 ,@(compile-progn body))))
423 (define-expression-operator labels (fn-defs &rest body)
424 (let* ((fn-renames (collect-function-names fn-defs))
425 (*local-function-names* (append fn-renames *local-function-names*))
426 (*enclosing-lexicals* (append fn-renames *enclosing-lexicals*))
427 (*loop-scope-lexicals* (when in-loop-scope? (append fn-renames *loop-scope-lexicals*))))
428 `(,(if compile-expression? 'ps-js:|,| 'ps-js:block)
429 ,@(loop for (fn-name . (args . body)) in fn-defs collect
430 (progn (when compile-expression?
431 (push (getf *local-function-names* fn-name) *enclosing-lexical-block-declarations*))
432 `(,(if compile-expression? 'ps-js:= 'ps-js:var)
433 ,(getf *local-function-names* fn-name)
434 (ps-js:lambda ,args
435 ,(let ((*function-block-name* fn-name))
436 (compile-function-definition args body))))))
437 ,@(compile-progn body))))
439 (define-expression-operator function (fn-name)
440 (ps-compile (maybe-rename-local-function fn-name)))
442 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
443 ;;; macros
445 (defmacro with-local-macro-environment ((var env) &body body)
446 `(let* ((,var (make-macro-dictionary))
447 (,env (cons ,var ,env)))
448 ,@body))
450 (define-expression-operator macrolet (macros &body body)
451 (with-local-macro-environment (local-macro-dict *macro-env*)
452 (dolist (macro macros)
453 (destructuring-bind (name arglist &body body)
454 macro
455 (setf (gethash name local-macro-dict)
456 (eval (make-ps-macro-function arglist body)))))
457 (ps-compile `(progn ,@body))))
459 (define-expression-operator symbol-macrolet (symbol-macros &body body)
460 (with-local-macro-environment (local-macro-dict *symbol-macro-env*)
461 (let (local-var-bindings)
462 (dolist (macro symbol-macros)
463 (destructuring-bind (name expansion) macro
464 (setf (gethash name local-macro-dict) (lambda (x) (declare (ignore x)) expansion))
465 (push name local-var-bindings)))
466 (let ((*enclosing-lexicals* (append local-var-bindings *enclosing-lexicals*)))
467 (ps-compile `(progn ,@body))))))
469 (define-expression-operator defmacro (name args &body body)
470 (eval `(defpsmacro ,name ,args ,@body))
471 nil)
473 (define-expression-operator define-symbol-macro (name expansion)
474 (eval `(define-ps-symbol-macro ,name ,expansion))
475 nil)
477 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
478 ;;; assignment and binding
480 (defun assignment-op (op)
481 (getf '(ps-js:+ ps-js:+=
482 ps-js:~ ps-js:~=
483 ps-js:& ps-js:&=
484 ps-js:\| ps-js:\|=
485 ps-js:- ps-js:-=
486 ps-js:* ps-js:*=
487 ps-js:% ps-js:%=
488 ps-js:>> ps-js:>>=
489 ps-js:^ ps-js:^=
490 ps-js:<< ps-js:<<=
491 ps-js:>>> ps-js:>>>=
492 ps-js:/ ps-js:/=)
493 op))
495 (define-expression-operator ps-assign (lhs rhs)
496 (let ((rhs (ps-macroexpand rhs)))
497 (if (and (listp rhs) (eq (car rhs) 'progn))
498 (ps-compile `(progn ,@(butlast (cdr rhs)) (ps-assign ,lhs ,(car (last (cdr rhs))))))
499 (let ((lhs (compile-expression lhs))
500 (rhs (compile-expression rhs)))
501 (aif (and (listp rhs)
502 (= 3 (length rhs))
503 (equal lhs (second rhs))
504 (assignment-op (first rhs)))
505 (list it lhs (if (fourth rhs)
506 (cons (first rhs) (cddr rhs))
507 (third rhs)))
508 (list 'ps-js:= lhs rhs))))))
510 (define-expression-operator let (bindings &body body)
511 (with-declaration-effects body
512 (let* ((lexical-bindings-introduced-here ())
513 (normalized-bindings (mapcar (lambda (x)
514 (if (symbolp x)
515 (list x nil)
516 (list (car x) (ps-macroexpand (cadr x)))))
517 bindings))
518 (free-variables-in-binding-value-expressions (mapcan (lambda (x) (flatten (cadr x)))
519 normalized-bindings)))
520 (flet ((maybe-rename-lexical-var (x)
521 (if (or (member x *enclosing-lexicals*)
522 (lookup-macro-def x *symbol-macro-env*)
523 (member x free-variables-in-binding-value-expressions))
524 (ps-gensym (string x))
525 (progn (push x lexical-bindings-introduced-here) nil)))
526 (rename (x) (first x))
527 (var (x) (second x))
528 (val (x) (third x)))
529 (let* ((lexical-bindings (loop for x in normalized-bindings
530 unless (special-variable? (car x))
531 collect (cons (maybe-rename-lexical-var (car x)) x)))
532 (dynamic-bindings (loop for x in normalized-bindings
533 when (special-variable? (car x))
534 collect (cons (ps-gensym (format nil "~A_~A" (car x) 'tmp-stack)) x)))
535 (renamed-body `(symbol-macrolet ,(loop for x in lexical-bindings
536 when (rename x) collect
537 `(,(var x) ,(rename x)))
538 ,@body))
539 (*enclosing-lexicals* (append lexical-bindings-introduced-here *enclosing-lexicals*))
540 (*loop-scope-lexicals* (when in-loop-scope? (append lexical-bindings-introduced-here *loop-scope-lexicals*))))
541 (ps-compile
542 `(progn
543 ,@(mapcar (lambda (x) `(var ,(or (rename x) (var x)) ,(val x)))
544 lexical-bindings)
545 ,(if dynamic-bindings
546 `(progn ,@(mapcar (lambda (x) `(var ,(rename x)))
547 dynamic-bindings)
548 (try (progn
549 (setf ,@(loop for x in dynamic-bindings append
550 `(,(rename x) ,(var x)
551 ,(var x) ,(val x))))
552 ,renamed-body)
553 (:finally
554 (setf ,@(mapcan (lambda (x) `(,(var x) ,(rename x)))
555 dynamic-bindings)))))
556 renamed-body))))))))
558 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
559 ;;; iteration
561 (defun make-for-vars/inits (init-forms)
562 (mapcar (lambda (x)
563 (cons (ps-macroexpand (if (atom x) x (first x)))
564 (compile-expression (if (atom x) nil (second x)))))
565 init-forms))
567 (defun compile-loop-body (loop-vars body)
568 (let* ((in-loop-scope? t)
569 (*loop-scope-lexicals* loop-vars)
570 (*loop-scope-lexicals-captured* ())
571 (*ps-gensym-counter* *ps-gensym-counter*)
572 (compiled-body (compile-statement `(progn ,@body))))
573 (aif (remove-duplicates *loop-scope-lexicals-captured*)
574 `(ps-js:block
575 (ps-js:with ,(compile-expression
576 `(create ,@(loop for x in it
577 collect x
578 collect (when (member x loop-vars) x))))
579 ,compiled-body))
580 compiled-body)))
582 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
583 ;;; evalutation
585 (define-expression-operator quote (x)
586 (flet ((quote% (expr) (when expr `',expr)))
587 (compile-expression
588 (typecase x
589 (cons `(array ,@(mapcar #'quote% x)))
590 (null '(array))
591 (keyword x)
592 (symbol (symbol-to-js-string x))
593 (number x)
594 (string x)
595 (vector `(array ,@(loop for el across x collect (quote% el))))))))
597 (define-expression-operator eval-when (situation-list &body body)
598 "The body is evaluated only during the given situations. The
599 accepted situations are :load-toplevel, :compile-toplevel,
600 and :execute. The code in BODY is assumed to be Common Lisp code
601 in :compile-toplevel and :load-toplevel sitations, and Parenscript
602 code in :execute."
603 (when (and (member :compile-toplevel situation-list)
604 (member *compilation-level* '(:toplevel :inside-toplevel-form)))
605 (eval `(progn ,@body)))
606 (if (member :execute situation-list)
607 (ps-compile `(progn ,@body))
608 (ps-compile `(progn))))