src/special-operators.lisp

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