src/special-operators.lisp

   1 (in-package #:parenscript)
   2
   3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   4 ;;; arithmetic and logic
   5
   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:\|\|
  14
  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:>>
  22
  23   throw      ps-js:throw
  24   aref       ps-js:aref
  25
  26   funcall    ps-js:funcall
  27   )
  28
  29 (define-expression-operator - (&rest args)
  30   (let ((args (mapcar #'compile-expression args)))
  31     (cons (if (cdr args) 'ps-js:- 'ps-js:negate) args)))
  32
  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))))))
  44
  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:==))
  61
  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)))
  66
  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)))))
  72
  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)))))
  78
  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))))))
  92
  93 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  94 ;;; blocks and control flow
  95
  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))))))
 107
 108 (define-expression-operator progn (&rest body)
 109   (if (cdr body)
 110       `(ps-js:|,| ,@(compile-progn body))
 111       (compile-expression (car body))))
 112
 113 (define-statement-operator progn (&rest body)
 114   `(ps-js:block ,@(compile-progn body)))
 115
 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))
 126
 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))))))
 132
 133 (defun nesting-depth (form)
 134   (if (consp form)
 135       (max (1+ (nesting-depth (car form))) (nesting-depth (cdr form)))
 136       0))
 137
 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)))
 171                                                       1)
 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)
 205                    (if
 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))))))
 216
 217 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 218 ;;; conditionals
 219
 220 (define-expression-operator if (test then &optional else)
 221    `(ps-js:? ,(compile-expression test) ,(compile-expression then) ,(compile-expression else)))
 222
 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))))))
 227
 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))))))))
 237
 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)))))))
 246
 247 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 248 ;;; function
 249
 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))
 259
 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)))))
 275
 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))))
 283
 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))))))
 293
 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.
 297
 298 Syntax of key spec:
 299 [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}*
 300 "
 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)))
 311
 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)))
 320
 321 (defun parse-extended-function (lambda-list body)
 322   ;; The lambda list is transformed as follows:
 323
 324   ;; * standard and optional variables are the mapped directly into
 325   ;;   the js-lambda list
 326
 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
 380                                       ,i)
 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))))
 391
 392 (defun maybe-rename-local-function (fun-name)
 393   (aif (getf *local-function-names* fun-name)
 394        it
 395        fun-name))
 396
 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)))
 403
 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))))
 422
 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))))
 438
 439 (define-expression-operator function (fn-name)
 440   (ps-compile (maybe-rename-local-function fn-name)))
 441
 442 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 443 ;;; macros
 444
 445 (defmacro with-local-macro-environment ((var env) &body body)
 446   `(let* ((,var (make-macro-dictionary))
 447           (,env (cons ,var ,env)))
 448      ,@body))
 449
 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))))
 458
 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))))))
 468
 469 (define-expression-operator defmacro (name args &body body)
 470   (eval `(defpsmacro ,name ,args ,@body))
 471   nil)
 472
 473 (define-expression-operator define-symbol-macro (name expansion)
 474   (eval `(define-ps-symbol-macro ,name ,expansion))
 475   nil)
 476
 477 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 478 ;;; assignment and binding
 479
 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))
 494
 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))))))
 509
 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))))))))
 557
 558 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 559 ;;; iteration
 560
 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))
 566
 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)))
 581
 582 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 583 ;;; evalutation
 584
 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))))))))
 596
 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))))