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
 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 label (label &rest body) ;; does label need to do symbol-macro expansion?
 129   `(js:label ,label ,(compile-statement `(progn ,@body))))
 130
 131 (define-statement-operator continue (&optional label)
 132   `(js:continue ,label))
 133
 134 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 135 ;;; conditionals
 136
 137 (define-expression-operator if (test then &optional else)
 138    `(js:? ,(compile-expression test) ,(compile-expression then) ,(compile-expression else)))
 139
 140 (define-statement-operator if (test then &optional else)
 141   `(js:if ,(compile-expression test)
 142           ,(compile-statement `(progn ,then))
 143           ,@(when else `(:else ,(compile-statement `(progn ,else))))))
 144
 145 (define-expression-operator cond (&rest clauses)
 146   (compile-expression
 147    (when clauses
 148      (destructuring-bind (test &rest body) (car clauses)
 149        (if (eq t test)
 150            `(progn ,@body)
 151            `(if ,test
 152                 (progn ,@body)
 153                 (cond ,@(cdr clauses))))))))
 154
 155 (define-statement-operator cond (&rest clauses)
 156   `(js:if ,(compile-expression (caar clauses))
 157           ,(compile-statement `(progn ,@(cdar clauses)))
 158           ,@(loop for (test . body) in (cdr clauses) appending
 159                  (if (eq t test)
 160                      `(:else ,(compile-statement `(progn ,@body)))
 161                      `(:else-if ,(compile-expression test)
 162                                 ,(compile-statement `(progn ,@body)))))))
 163
 164 (define-statement-operator switch (test-expr &rest clauses)
 165   `(js:switch ,(compile-expression test-expr)
 166      ,@(loop for (val . body) in clauses collect
 167             (cons (if (eq val 'default)
 168                       'js:default
 169                       (compile-expression val))
 170                   (mapcan (lambda (x)
 171                             (let ((exp (compile-statement x)))
 172                               (if (and (listp exp) (eq 'js:block (car exp)))
 173                                   (cdr exp)
 174                                   (list exp))))
 175                           body)))))
 176
 177 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 178 ;;; function
 179
 180 (defun nesting-depth (form) ;; some heuristics
 181   (if (atom form)
 182       0
 183       (1+ (apply #'max (mapcar #'nesting-depth form)))))
 184
 185 (define-statement-operator return-from (tag &optional form)
 186   (let ((form (ps-macroexpand form)))
 187     (if (listp form)
 188         (block expressionize
 189           (ps-compile
 190            (case (car form)
 191              (progn
 192                `(progn ,@(butlast (cdr form)) (return-from ,tag ,(car (last (cdr form))))))
 193              (switch
 194                `(switch ,(second form)
 195                   ,@(loop for (cvalue . cbody) in (cddr form)
 196                           for remaining on (cddr form) collect
 197                          (let ((last-n (cond ((or (eq 'default cvalue) (not (cdr remaining)))
 198                                               1)
 199                                              ((eq 'break (car (last cbody)))
 200                                               2))))
 201                            (if last-n
 202                                (let ((result-form (car (last cbody last-n))))
 203                                  `(,cvalue
 204                                    ,@(butlast cbody last-n)
 205                                    (return-from ,tag ,result-form)
 206                                    ,@(when (and (= last-n 2) (member 'if (flatten result-form))) '(break))))
 207                                (cons cvalue cbody))))))
 208              (try
 209               `(try (return-from ,tag ,(second form))
 210                     ,@(let ((catch (cdr (assoc :catch (cdr form))))
 211                             (finally (assoc :finally (cdr form))))
 212                            (list (when catch
 213                                    `(:catch ,(car catch)
 214                                       ,@(butlast (cdr catch))
 215                                       (return-from ,tag ,(car (last (cdr catch))))))
 216                                  finally))))
 217              (cond
 218                `(cond ,@(loop for clause in (cdr form) collect
 219                              `(,@(butlast clause)
 220                                  (return-from ,tag ,(car (last clause)))))))
 221              ((with label let flet labels macrolet symbol-macrolet) ;; implicit progn forms
 222               `(,(first form) ,(second form)
 223                  ,@(butlast (cddr form))
 224                  (return-from ,tag ,(car (last (cddr form))))))
 225              ((continue break throw) ;; non-local exit
 226               form)
 227              (return-from ;; this will go away someday
 228                (unless tag
 229                  (warn 'simple-style-warning
 230                        :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."))
 231                form)
 232              (if
 233               (aif (and (< (nesting-depth form) 5) (handler-case (compile-expression form) (compile-expression-error () nil)))
 234                   (return-from expressionize `(js:return ,it))
 235                   `(if ,(second form)
 236                        (return-from ,tag ,(third form))
 237                        ,@(when (fourth form) `((%function-return ,(fourth form)))))))
 238              (otherwise
 239               (if (gethash (car form) *special-statement-operators*)
 240                   form ;; by now only special forms that return nil should be left, so this is ok
 241                   (return-from expressionize `(js:return ,(compile-expression form))))))))
 242         `(js:return ,(compile-expression form)))))
 243
 244 (defmacro with-declaration-effects (body-var &body body)
 245   `(let* ((local-specials (when (and (listp (car ,body-var))
 246                                      (eq (caar ,body-var) 'declare))
 247                             (cdr (find 'special (cdar ,body-var) :key #'car))))
 248           (,body-var (if local-specials
 249                          (cdr ,body-var)
 250                          ,body-var))
 251           (*special-variables* (append local-specials *special-variables*)))
 252      ,@body))
 253
 254 (defun compile-function-definition (args body)
 255   (with-declaration-effects body
 256     (let* ((*enclosing-lexical-block-declarations* ())
 257            (*ps-enclosing-lexicals* (append args *ps-enclosing-lexicals*))
 258            (body (compile-statement `(return-from %function-body (progn ,@body))))
 259            (var-decls (compile-statement
 260                        `(progn ,@(mapcar (lambda (var) `(var ,var))
 261                                          (remove-duplicates *enclosing-lexical-block-declarations*))))))
 262       `(js:block ,@(cdr var-decls) ,@(cdr body)))))
 263
 264 (define-expression-operator %js-lambda (args &rest body)
 265   `(js:lambda ,args ,(compile-function-definition args body)))
 266
 267 (define-statement-operator %js-defun (name args &rest body)
 268   (let ((docstring (and (cdr body) (stringp (car body)) (car body))))
 269     `(js:defun ,name ,args ,docstring
 270                ,(compile-function-definition args
 271                                              (if docstring (cdr body) body)))))
 272
 273 (defun parse-key-spec (key-spec)
 274   "parses an &key parameter.  Returns 5 values:
 275 var, init-form,  keyword-name, supplied-p-var, init-form-supplied-p.
 276
 277 Syntax of key spec:
 278 [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}*
 279 "
 280   (let* ((var (cond ((symbolp key-spec) key-spec)
 281                     ((and (listp key-spec) (symbolp (first key-spec))) (first key-spec))
 282                     ((and (listp key-spec) (listp (first key-spec)))   (second (first key-spec)))))
 283          (keyword-name (if (and (listp key-spec) (listp (first key-spec)))
 284                            (first (first key-spec))
 285                            (intern (string var) :keyword)))
 286          (init-form (if (listp key-spec) (second key-spec) nil))
 287          (init-form-supplied-p (if (listp key-spec) t nil))
 288          (supplied-p-var (if (listp key-spec) (third key-spec) nil)))
 289     (values var init-form keyword-name supplied-p-var init-form-supplied-p)))
 290
 291 (defun parse-optional-spec (spec)
 292   "Parses an &optional parameter.  Returns 3 values: var, init-form, supplied-p-var.
 293 [&optional {var | (var [init-form [supplied-p-parameter]])}*] "
 294   (let* ((var (cond ((symbolp spec) spec)
 295                     ((and (listp spec) (first spec)))))
 296          (init-form (if (listp spec) (second spec)))
 297          (supplied-p-var (if (listp spec) (third spec))))
 298     (values var init-form supplied-p-var)))
 299
 300 (defun parse-aux-spec (spec)
 301   "Returns two values: variable and init-form"
 302   ;; [&aux {var | (var [init-form])}*])
 303   (values (if (symbolp spec) spec (first spec))
 304           (when (listp spec) (second spec))))
 305
 306 (defun parse-extended-function (lambda-list body)
 307   ;; The lambda list is transformed as follows:
 308
 309   ;; * standard and optional variables are the mapped directly into
 310   ;;   the js-lambda list
 311
 312   ;; * keyword variables are not included in the js-lambda list, but
 313   ;;   instead are obtained from the magic js ARGUMENTS
 314   ;;   pseudo-array. Code assigning values to keyword vars is
 315   ;;   prepended to the body of the function.
 316   (multiple-value-bind (requireds optionals rest? rest keys? keys allow? aux?
 317                                   aux more? more-context more-count key-object)
 318       (parse-lambda-list lambda-list)
 319     (declare (ignore allow? aux? aux more? more-context more-count key-object))
 320     (let* ( ;; optionals are of form (var default-value)
 321            (effective-args
 322             (remove-if #'null
 323                        (append requireds
 324                                (mapcar #'parse-optional-spec optionals))))
 325            (opt-forms
 326             (mapcar (lambda (opt-spec)
 327                       (multiple-value-bind (name value suppl)
 328                           (parse-optional-spec opt-spec)
 329                         (if suppl
 330                             `(progn
 331                                (var ,suppl (not (eql ,name undefined)))
 332                                (when (not ,suppl) (setf ,name ,value)))
 333                             `(when (eql ,name undefined)
 334                                (setf ,name ,value)))))
 335                     optionals))
 336            (key-forms
 337             (when keys?
 338               (with-ps-gensyms (n)
 339                 (let ((decls ())
 340                       (assigns ()))
 341                   (mapc
 342                    (lambda (k)
 343                      (multiple-value-bind (var init-form keyword-str suppl)
 344                          (parse-key-spec k)
 345                        (push `(var ,var ,init-form) decls)
 346                        (when suppl (push `(var ,suppl nil) decls))
 347                        (push `(,keyword-str
 348                                (setf ,var (aref arguments (1+ ,n))
 349                                      ,@(when suppl `(,suppl t))))
 350                              assigns)))
 351                    (reverse keys))
 352                   `(,@decls
 353                     (loop for ,n from ,(length requireds)
 354                        below (length arguments) by 2 do
 355                          (case (aref arguments ,n) ,@assigns)))))))
 356            (rest-form
 357             (when rest?
 358               (with-ps-gensyms (i)
 359                 `(progn (var ,rest (array))
 360                         (dotimes (,i (- (getprop arguments 'length)
 361                                         ,(length effective-args)))
 362                           (setf (aref ,rest
 363                                       ,i)
 364                                 (aref arguments
 365                                       (+ ,i ,(length effective-args)))))))))
 366            (docstring (when (stringp (first body)) (first body)))
 367            (body-paren-forms (if docstring (rest body) body))
 368            (effective-body (append (when docstring (list docstring))
 369                                    opt-forms
 370                                    key-forms
 371                                    (awhen rest-form (list it))
 372                                    body-paren-forms)))
 373       (values effective-args effective-body))))
 374
 375 (defun maybe-rename-local-function (fun-name)
 376   (aif (getf *ps-local-function-names* fun-name)
 377        it
 378        fun-name))
 379
 380 (defun collect-function-names (fn-defs)
 381   (loop for (fn-name) in fn-defs
 382      collect fn-name
 383      collect (if (or (member fn-name *ps-enclosing-lexicals*)
 384                      (lookup-macro-def fn-name *ps-symbol-macro-env*))
 385                  (ps-gensym fn-name)
 386                  fn-name)))
 387
 388 (define-expression-operator flet (fn-defs &rest body)
 389   (let* ((fn-renames (collect-function-names fn-defs))
 390          ;; the function definitions need to be compiled with previous lexical bindings
 391          (fn-defs (loop for (fn-name . def) in fn-defs collect
 392                        (ps-compile `(var ,(getf fn-renames fn-name) (lambda ,@def)))))
 393          ;; the flet body needs to be compiled with the extended lexical environment
 394          (*ps-enclosing-lexicals* (append fn-renames *ps-enclosing-lexicals*))
 395          (*ps-local-function-names* (append fn-renames *ps-local-function-names*)))
 396     `(,(if compile-expression? 'js:|,| 'js:block)
 397        ,@fn-defs
 398        ,@(compile-progn body))))
 399
 400 (define-expression-operator labels (fn-defs &rest body)
 401   (let* ((fn-renames (collect-function-names fn-defs))
 402          (*ps-local-function-names*
 403           (append fn-renames *ps-local-function-names*))
 404          (*ps-enclosing-lexicals*
 405           (append fn-renames *ps-enclosing-lexicals*)))
 406     (ps-compile
 407      `(progn ,@(loop for (fn-name . def) in fn-defs collect
 408                     `(var ,(getf *ps-local-function-names* fn-name)
 409                           (lambda ,@def)))
 410              ,@body))))
 411
 412 (define-expression-operator function (fn-name)
 413   (ps-compile (maybe-rename-local-function fn-name)))
 414
 415 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 416 ;;; macros
 417
 418 (defmacro with-local-macro-environment ((var env) &body body)
 419   `(let* ((,var (make-macro-dictionary))
 420           (,env (cons ,var ,env)))
 421      ,@body))
 422
 423 (define-expression-operator macrolet (macros &body body)
 424   (with-local-macro-environment (local-macro-dict *ps-macro-env*)
 425     (dolist (macro macros)
 426       (destructuring-bind (name arglist &body body)
 427           macro
 428         (setf (gethash name local-macro-dict)
 429               (eval (make-ps-macro-function arglist body)))))
 430     (ps-compile `(progn ,@body))))
 431
 432 (define-expression-operator symbol-macrolet (symbol-macros &body body)
 433   (with-local-macro-environment (local-macro-dict *ps-symbol-macro-env*)
 434     (let (local-var-bindings)
 435       (dolist (macro symbol-macros)
 436         (destructuring-bind (name expansion)
 437             macro
 438           (setf (gethash name local-macro-dict) (lambda (x)
 439                                                   (declare (ignore x))
 440                                                   expansion))
 441           (push name local-var-bindings)))
 442       (let ((*ps-enclosing-lexicals*
 443              (append local-var-bindings
 444                      *ps-enclosing-lexicals*)))
 445         (ps-compile `(progn ,@body))))))
 446
 447 (define-expression-operator defmacro (name args &body body)
 448   (eval `(defpsmacro ,name ,args ,@body))
 449   nil)
 450
 451 (define-expression-operator define-symbol-macro (name expansion)
 452   (eval `(define-ps-symbol-macro ,name ,expansion))
 453   nil)
 454
 455 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 456 ;;; objects
 457
 458 (define-expression-operator create (&rest arrows)
 459   `(js:object
 460     ,@(loop for (key val-expr) on arrows by #'cddr collecting
 461            (progn
 462              (assert (or (stringp key) (numberp key) (symbolp key))
 463                      ()
 464                      "Slot key ~s is not one of symbol, string or number."
 465                      key)
 466              (cons (aif (and (symbolp key) (reserved-symbol? key)) it key)
 467                    (compile-expression val-expr))))))
 468
 469 (define-expression-operator %js-getprop (obj slot)
 470   (let ((expanded-slot (ps-macroexpand slot))
 471         (obj (compile-expression obj)))
 472     (if (and (listp expanded-slot)
 473              (eq 'quote (car expanded-slot)))
 474         (aif (or (reserved-symbol? (second expanded-slot))
 475                  (and (keywordp (second expanded-slot)) (second expanded-slot)))
 476              `(js:aref ,obj ,it)
 477              `(js:getprop ,obj ,(second expanded-slot)))
 478         `(js:aref ,obj ,(compile-expression slot)))))
 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 var (name &optional (value (values) value?) docstr)
 514   (declare (ignore docstr))
 515   (push name *enclosing-lexical-block-declarations*)
 516   (when value? (compile-expression `(setf ,name ,value))))
 517
 518 (define-statement-operator var (name &optional (value (values) value?) docstr)
 519   `(js:var ,(ps-macroexpand name) ,@(when value? (list (compile-expression value) docstr))))
 520
 521 (define-expression-operator let (bindings &body body)
 522   (with-declaration-effects body
 523     (let* ((lexical-bindings-introduced-here ())
 524            (normalized-bindings
 525             (mapcar (lambda (x)
 526                       (if (symbolp x)
 527                           (list x nil)
 528                           (list (car x) (ps-macroexpand (cadr x)))))
 529                     bindings))
 530            (free-variables-in-binding-value-expressions
 531             (mapcan (lambda (x) (flatten (cadr x)))
 532                     normalized-bindings)))
 533       (flet ((maybe-rename-lexical-var (x)
 534                (if (or (member x *ps-enclosing-lexicals*)
 535                        (lookup-macro-def x *ps-symbol-macro-env*)
 536                        (member x free-variables-in-binding-value-expressions))
 537                    (ps-gensym x)
 538                    (progn (push x lexical-bindings-introduced-here) nil)))
 539              (rename (x) (first x))
 540              (var (x) (second x))
 541              (val (x) (third x)))
 542         (let* ((lexical-bindings
 543                 (loop for x in normalized-bindings
 544                       unless (special-variable? (car x))
 545                       collect (cons (maybe-rename-lexical-var (car x)) x)))
 546                (dynamic-bindings
 547                 (loop for x in normalized-bindings
 548                       when (special-variable? (car x))
 549                       collect (cons (ps-gensym (format nil "~A_~A" (car x) 'tmp-stack)) x)))
 550                (renamed-body `(symbol-macrolet ,(loop for x in lexical-bindings
 551                                                    when (rename x) collect
 552                                                    `(,(var x) ,(rename x)))
 553                                 ,@body))
 554                (*ps-enclosing-lexicals*
 555                 (append lexical-bindings-introduced-here
 556                         *ps-enclosing-lexicals*)))
 557           (ps-compile
 558            `(progn
 559               ,@(mapcar (lambda (x) `(var ,(or (rename x) (var x)) ,(val x)))
 560                         lexical-bindings)
 561               ,(if dynamic-bindings
 562                    `(progn ,@(mapcar (lambda (x) `(var ,(rename x)))
 563                                      dynamic-bindings)
 564                            (try (progn
 565                                   (setf ,@(loop for x in dynamic-bindings append
 566                                                `(,(rename x) ,(var x)
 567                                                   ,(var x) ,(val x))))
 568                                   ,renamed-body)
 569                                 (:finally
 570                                  (setf ,@(mapcan (lambda (x) `(,(var x) ,(rename x)))
 571                                                  dynamic-bindings)))))
 572                    renamed-body))))))))
 573
 574 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 575 ;;; iteration
 576
 577 (defun make-for-vars/inits (init-forms)
 578   (mapcar (lambda (x)
 579             (cons (ps-macroexpand (if (atom x) x (first x)))
 580                   (compile-expression (if (atom x) nil (second x)))))
 581           init-forms))
 582
 583 (define-statement-operator for (init-forms cond-forms step-forms &body body)
 584   `(js:for ,(make-for-vars/inits init-forms)
 585      ,(mapcar #'compile-expression cond-forms)
 586      ,(mapcar #'compile-expression step-forms)
 587      ,(compile-statement `(progn ,@body))))
 588
 589 (define-statement-operator for-in ((var object) &rest body)
 590   `(js:for-in ,(compile-expression var)
 591               ,(compile-expression object)
 592               ,(compile-statement `(progn ,@body))))
 593
 594 (define-statement-operator while (test &rest body)
 595   `(js:while ,(compile-expression test)
 596      ,(compile-statement `(progn ,@body))))
 597
 598 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 599 ;;; misc
 600
 601 (define-statement-operator with (expression &rest body) ;; this should be deprecated
 602   `(js:with ,(compile-expression expression)
 603      ,(compile-statement `(progn ,@body))))
 604
 605 (define-statement-operator try (form &rest clauses)
 606   (let ((catch (cdr (assoc :catch clauses)))
 607         (finally (cdr (assoc :finally clauses))))
 608     (assert (not (cdar catch)) () "Sorry, currently only simple catch forms are supported.")
 609     (assert (or catch finally) () "Try form should have either a catch or a finally clause or both.")
 610     `(js:try ,(compile-statement `(progn ,form))
 611              :catch ,(when catch (list (caar catch) (compile-statement `(progn ,@(cdr catch)))))
 612              :finally ,(when finally (compile-statement `(progn ,@finally))))))
 613
 614 (define-expression-operator regex (regex)
 615   `(js:regex ,(string regex)))
 616
 617 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 618 ;;; evalutation
 619
 620 (define-expression-operator quote (x)
 621   (flet ((quote% (expr) (when expr `',expr)))
 622     (compile-expression
 623      (typecase x
 624        (cons `(array ,@(mapcar #'quote% x)))
 625        (null '(array))
 626        (keyword x)
 627        (symbol (symbol-to-js-string x))
 628        (number x)
 629        (string x)
 630        (vector `(array ,@(loop for el across x collect (quote% el))))))))
 631
 632 (define-expression-operator lisp (lisp-form)
 633   ;; (ps (foo (lisp bar))) is like (ps* `(foo ,bar))
 634   ;; When called from inside of ps*, lisp-form has access to the
 635   ;; dynamic environment only, analogous to eval.
 636   `(js:escape
 637     (with-output-to-string (*psw-stream*)
 638       (let ((compile-expression? ,compile-expression?))
 639         (parenscript-print (ps-compile ,lisp-form) t)))))
 640
 641 (define-expression-operator eval-when (situation-list &body body)
 642   "The body is evaluated only during the given situations. The
 643 accepted situations are :load-toplevel, :compile-toplevel,
 644 and :execute. The code in BODY is assumed to be Common Lisp code
 645 in :compile-toplevel and :load-toplevel sitations, and Parenscript
 646 code in :execute."
 647   (when (and (member :compile-toplevel situation-list)
 648              (member *compilation-level* '(:toplevel :inside-toplevel-form)))
 649     (eval `(progn ,@body)))
 650   (if (member :execute situation-list)
 651       (ps-compile `(progn ,@body))
 652       (ps-compile `(progn))))