src/special-operators.lisp

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