src/special-forms.lisp

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