src/special-operators.lisp

   1 ;;; Copyright 2005 Manuel Odendahl
   2 ;;; Copyright 2005-2006 Edward Marco Baringer
   3 ;;; Copyright 2007-2012 Vladimir Sedach
   4 ;;; Copyright 2011-2013 Daniel Gackle
   5 ;;; Copyright 2014 Boris Smilga
   6
   7 ;;; SPDX-License-Identifier: BSD-3-Clause
   8
   9 ;;; Redistribution and use in source and binary forms, with or
  10 ;;; without modification, are permitted provided that the following
  11 ;;; conditions are met:
  12
  13 ;;; 1. Redistributions of source code must retain the above copyright
  14 ;;; notice, this list of conditions and the following disclaimer.
  15
  16 ;;; 2. Redistributions in binary form must reproduce the above
  17 ;;; copyright notice, this list of conditions and the following
  18 ;;; disclaimer in the documentation and/or other materials provided
  19 ;;; with the distribution.
  20
  21 ;;; 3. Neither the name of the copyright holder nor the names of its
  22 ;;; contributors may be used to endorse or promote products derived
  23 ;;; from this software without specific prior written permission.
  24
  25 ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
  26 ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
  27 ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
  28 ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  29 ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS
  30 ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
  31 ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
  32 ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  33 ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
  34 ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
  35 ;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  36 ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  37 ;;; POSSIBILITY OF SUCH DAMAGE.
  38
  39 (in-package #:parenscript)
  40 (in-readtable :parenscript)
  41
  42 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  43 ;;; arithmetic and logic
  44
  45 (define-trivial-special-ops
  46   +          ps-js:+
  47   -          ps-js:-
  48   *          ps-js:*
  49   rem        ps-js:%
  50   and        ps-js:&&
  51   or         ps-js:\|\|
  52
  53   logand     ps-js:&
  54   logior     ps-js:\|
  55   logxor     ps-js:^
  56   lognot     ps-js:~
  57
  58   aref       ps-js:aref
  59
  60   funcall    ps-js:funcall
  61   )
  62
  63 (define-expression-operator / (&rest args)
  64   `(ps-js:/ ,@(unless (cdr args) (list 1)) ,@(mapcar #'compile-expression args)))
  65
  66 (define-expression-operator + (&rest args)
  67   (let ((args (mapcar #'compile-expression args)))
  68     (cons (if (cdr args) 'ps-js:+ 'ps-js:unary-plus) args)))
  69
  70 (define-expression-operator - (&rest args)
  71   (let ((args (mapcar #'compile-expression args)))
  72     (cons (if (cdr args) 'ps-js:- 'ps-js:negate) args)))
  73
  74 (defun fix-nary-comparison (operator objects)
  75   (let* ((tmp-var-forms (butlast (cdr objects)))
  76          (tmp-vars (loop repeat (length tmp-var-forms)
  77                          collect (ps-gensym '_cmp)))
  78          (all-comparisons (append (list (car objects))
  79                                   tmp-vars
  80                                   (last objects))))
  81     `(let ,(mapcar #'list tmp-vars tmp-var-forms)
  82        (and ,@(loop for x1 in all-comparisons
  83                     for x2 in (cdr all-comparisons)
  84                     collect (list operator x1 x2))))))
  85
  86 (macrolet ((define-nary-comparison-forms (&rest mappings)
  87              `(progn
  88                 ,@(loop for (form js-primitive) on mappings by #'cddr collect
  89                        `(define-expression-operator ,form (&rest objects)
  90                           (if (cddr objects)
  91                               (ps-compile
  92                                (fix-nary-comparison ',form objects))
  93                               (cons ',js-primitive
  94                                     (mapcar #'compile-expression objects))))))))
  95   (define-nary-comparison-forms
  96     <     ps-js:<
  97     >     ps-js:>
  98     <=    ps-js:<=
  99     >=    ps-js:>=
 100     eql   ps-js:===
 101     equal ps-js:==))
 102
 103 (define-expression-operator /= (a b)
 104   ;; for n>2, /= is finding duplicates in an array of numbers (ie -
 105   ;; nontrivial runtime algorithm), so we restrict it to binary in PS
 106   `(ps-js:!== ,(compile-expression a) ,(compile-expression b)))
 107
 108 (defun references? (exp place)
 109   (cond ((not exp) nil)
 110         ((atom exp) (equal exp place))
 111         (t (or (equal exp place)
 112                (references? (car exp) place)
 113                (references? (cdr exp) place)))))
 114
 115 (defmacro inc-dec (op op1 op2)
 116   `(let ((delta (ps-macroexpand delta)))
 117      (cond ((eql delta 1)
 118             (list ',op1 (compile-expression x)))
 119            ((references? delta x)
 120             (ps-compile
 121              (let ((var (ps-gensym '_ps_incr_place)))
 122                `(let ((,var ,delta))
 123                   (,',op ,x ,var)))))
 124            (t
 125             (list ',op2 (compile-expression x)
 126                   (compile-expression delta))))))
 127
 128 (define-expression-operator incf (x &optional (delta 1))
 129   (inc-dec incf ps-js:++ ps-js:+=))
 130
 131 (define-expression-operator decf (x &optional (delta 1))
 132   (inc-dec decf ps-js:-- ps-js:-=))
 133
 134 (let ((inverses (mapcan (lambda (x)
 135                           (list x (reverse x)))
 136                         '((ps-js:=== ps-js:!==)
 137                           (ps-js:== ps-js:!=)
 138                           (ps-js:< ps-js:>=)
 139                           (ps-js:> ps-js:<=)))))
 140   (define-expression-operator not (x)
 141     (let ((form (compile-expression x)))
 142       (acond ((and (listp form) (eq (car form) 'ps-js:!)) ;; not not → identity
 143               (second form))
 144              ((and (listp form) (cadr (assoc (car form) inverses))) ;; not equal → !=
 145               `(,it ,@(cdr form)))
 146              (t `(ps-js:! ,form))))))
 147
 148 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 149 ;;; blocks and control flow
 150
 151 (defun compile-progn (body)
 152   (let ((block (flatten-blocks (mapcar #'ps-compile body))))
 153     (append (remove-if #'constantp (butlast block))
 154             (unless (and (or (eq *compilation-level* :toplevel)
 155                              (not compile-expression?))
 156                          (not (car (last block))))
 157               (last block)))))
 158
 159 (define-expression-operator progn (&rest body)
 160   (if (cdr body)
 161       `(ps-js:|,| ,@(compile-progn body))
 162       (compile-expression (car body))))
 163
 164 (define-statement-operator progn (&rest body)
 165   `(ps-js:block ,@(compile-progn body)))
 166
 167 (defvar returning-values? nil)
 168
 169 (defun wrap-for-dynamic-return (handled-tags body)
 170   (aif (loop for (tag . thrown?) in *dynamic-return-tags*
 171              when (and thrown? (member tag handled-tags))
 172              collect tag)
 173        (with-ps-gensyms (_ps_err)
 174          (flet ((make-catch-clause (tag)
 175                   `((and ,_ps_err (eql ',tag
 176                                        (getprop ,_ps_err :__ps_block_tag)))
 177                     (return-from ,tag
 178                       (getprop ,_ps_err :__ps_value)
 179                       t))))
 180            `(ps-js:block
 181                (ps-js:try
 182                 ,body
 183                 :catch (,_ps_err
 184                         ,(compile-statement
 185                           `(progn (cond
 186                                     ,@(mapcar #'make-catch-clause it)
 187                                     (t (throw ,_ps_err))))))
 188                 :finally nil))))
 189        body))
 190
 191 (define-statement-operator block (name &rest body)
 192   (if in-function-scope?
 193       (let* ((name                  (or name 'nilBlock))
 194              (in-loop-scope?        (if name in-loop-scope? nil))
 195              (*dynamic-return-tags* (cons (cons name nil)
 196                                           *dynamic-return-tags*))
 197              (*current-block-tag*   name)
 198              (compiled-body         (wrap-for-dynamic-return
 199                                      (list name)
 200                                      (ps-compile `(progn ,@body)))))
 201         ;; this probably does not nest correctly
 202         (if (tree-find `(ps-js:break ,name) compiled-body)
 203             `(ps-js:label ,name ,compiled-body)
 204             compiled-body))
 205       (ps-compile (with-lambda-scope `(block ,name ,@body)))))
 206
 207 (define-expression-operator values (&rest forms)
 208   (ps-compile
 209    (with-ps-gensyms (val)
 210      `(let ((,val ,(car forms)))
 211         (setf __PS_MV_REG (list ,@(cdr forms)))
 212         ,val))))
 213
 214 (define-expression-operator values-list (list)
 215   (ps-compile
 216    (with-ps-gensyms (values-list firstval)
 217      `(let ((,values-list (funcall (getprop ,list 'slice))))
 218         (setf ,firstval   (funcall (getprop ,values-list 'shift))
 219               __PS_MV_REG ,values-list)
 220         ,firstval))))
 221
 222 (define-statement-operator %simple-lexical-return (&rest value)
 223   `(ps-js:return ,@value))
 224
 225 (defun return-exp (tag &optional (value nil value?))
 226   (flet ((lexical-return ()
 227            (let ((X (when value? (list (compile-expression value)))))
 228              (ps-compile
 229               (if (and (not returning-values?) clear-multiple-values?)
 230                   `(progn
 231                      (setf __PS_MV_REG '())
 232                      (%simple-lexical-return ,@X))
 233                   `(%simple-lexical-return ,@X))))))
 234     (acond
 235       ((eql tag *current-block-tag*)
 236        (compile-statement
 237         `(progn
 238            ,@(when (and (not returning-values?) clear-multiple-values?)
 239                '((setf __PS_MV_REG '())))
 240            ,@(when value? (list value))
 241            (break ,tag))))
 242
 243       ((or (eql '%function tag)
 244            (member tag *function-block-names*))
 245        (lexical-return))
 246
 247       ((assoc tag *dynamic-return-tags*)
 248        (setf (cdr it) t)
 249        (ps-compile
 250         `(progn
 251            ,@(unless returning-values?
 252                '((setf __PS_MV_REG '())))
 253            (throw (create
 254                    :__ps_block_tag ',tag
 255                    :__ps_value     ,value)))))
 256
 257       (t
 258        (warn "Returning from unknown block ~A" tag)
 259        (lexical-return)))))
 260
 261 (defun try-expressionizing-if? (exp &optional (score 0)) ;; poor man's codewalker
 262   "Heuristic that tries not to expressionize deeply nested if expressions."
 263   (cond ((< 1 score) nil)
 264         ((and (listp exp) (eq (car exp) 'quote))
 265          t)
 266         ((listp exp)
 267          (loop for x in (cdr exp) always
 268               (try-expressionizing-if?
 269                (or (ignore-errors (ps-macroexpand x))
 270                    x) ;; fail
 271                (+ score (case (car exp)
 272                           ((if cond) 1)
 273                           (let (if (second exp) 1 0)) ;; ignore empty binding list
 274                           ((progn) (1- (length (cdr exp))))
 275                           (otherwise 0))))))
 276         (t t)))
 277
 278 (defun return-result-of (tag form)
 279   (ps-compile
 280    (case (car form)
 281      ((continue break throw) ;; non-local exit
 282       form)
 283      ;; implicit progn forms
 284      ((with) ;; deprecated and will be removed
 285       `(,(first form) ,(second form)
 286          ,@(butlast (cddr form))
 287          (return-from ,tag ,(car (last (cddr form))))))
 288      ;; implicit body (declaration + progn) forms
 289      ((let flet labels macrolet symbol-macrolet)
 290       (multiple-value-bind (body declarations)
 291           (parse-body (cddr form))
 292         `(,(first form) ,(second form)
 293            ,@declarations
 294            ,@(butlast body)
 295            (return-from ,tag ,(car (last body))))))
 296      ((progn locally)
 297        `(progn ,@(butlast (cdr form))
 298                (return-from ,tag ,(car (last (cdr form))))))
 299      (switch
 300       `(switch
 301         ,(second form)
 302         ,@(loop for (cvalue . cbody) in (cddr form)
 303                 for remaining on (cddr form) collect
 304                 (aif (cond ((or (eq 'default cvalue) (not (cdr remaining)))
 305                             1)
 306                            ((eq 'break (car (last cbody)))
 307                             2))
 308                      (let ((result-form (ps-macroexpand
 309                                          (car (last cbody it)))))
 310                        `(,cvalue
 311                          ,@(butlast cbody it)
 312                          (return-from ,tag
 313                            ,(if (eq result-form 'break) nil result-form))))
 314                      (cons cvalue cbody)))))
 315      (try
 316       `(try (return-from ,tag ,(second form))
 317             ,@(let ((catch (cdr (assoc :catch (cdr form))))
 318                     (finally (assoc :finally (cdr form))))
 319                    (list (when catch
 320                            `(:catch ,(car catch)
 321                               ,@(butlast (cdr catch))
 322                               (return-from ,tag
 323                                 ,(car (last (cdr catch))))))
 324                          finally))))
 325      (cond
 326        `(cond
 327           ,@(loop for clause in (cdr form) collect
 328                   `(,@(butlast clause) (return-from ,tag ,(car (last clause)))))
 329           ,@(when in-case? `((t (return-from ,tag nil))))))
 330      (if
 331       (if (and (try-expressionizing-if? form)
 332                (not (tree-find 'values form))
 333                (let ((used-up-names                   *used-up-names*)
 334                      (*lambda-wrappable-statements*                ()))
 335                  (handler-case (compile-expression form)
 336                    (compile-expression-error ()
 337                      (setf *used-up-names* used-up-names)
 338                      nil))))
 339           (return-from return-result-of (return-exp tag form))
 340           `(if ,(second form)
 341                (return-from ,tag ,(third form))
 342                ,@(when (or in-case? (fourth form))
 343                    `((return-from ,tag ,(fourth form)))))))
 344      (block
 345       (let* ((tag₁                   (or (cadr form) 'nilBlock))
 346              (*function-block-names* (cons tag₁ *function-block-names*))
 347              (*dynamic-return-tags*  (cons (cons tag₁ nil)
 348                                            *dynamic-return-tags*)))
 349         (return-from return-result-of
 350           (wrap-for-dynamic-return
 351            (list tag₁)
 352            (ps-compile `(return-from ,tag (progn ,@(cddr form))))))))
 353      (values
 354       (if (cddr form)
 355           (with-ps-gensyms (val)
 356             `(let ((,val ,(cadr form)))
 357                (setf __PS_MV_REG (list ,@(cddr form)))
 358                (return-from ,tag ,val t)))
 359           `(return-from ,tag ,@(cdr form))))
 360      (values-list
 361       (with-ps-gensyms (values-list firstval)
 362         `(let ((,values-list (funcall (getprop ,(cadr form) 'slice))))
 363            (setf ,firstval   (funcall (getprop ,values-list 'shift))
 364                  __PS_MV_REG ,values-list)
 365            (return-from ,tag ,firstval t))))
 366      (return-from ;; this will go away someday
 367       (unless tag
 368         (warn 'simple-style-warning
 369               :format-control "Trying to RETURN a RETURN without a block tag specified. Perhaps you're still returning values from functions by hand?
 370 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."))
 371        form)
 372      (otherwise
 373       (return-from return-result-of
 374         (cond ((not (gethash (car form) *special-statement-operators*))
 375                (return-exp tag form))
 376               (in-case?
 377                `(ps-js:block ,(compile-statement form) ,(return-exp tag)))
 378               (t (compile-statement form))))))))
 379
 380 (define-statement-operator return-from (tag &optional
 381                                             (result nil result?)
 382                                             returning-values?)
 383   (setq tag (or tag 'nilBlock))
 384   (if result?
 385       (let ((form (ps-macroexpand result)))
 386         (if (atom form)
 387             (return-exp tag form)
 388             (return-result-of tag form)))
 389       (return-exp tag)))
 390
 391 (define-statement-operator throw (&rest args)
 392   `(ps-js:throw ,@(mapcar #'compile-expression args)))
 393
 394 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 395 ;;; conditionals
 396
 397 (define-expression-operator if (test then &optional else)
 398   `(ps-js:? ,(compile-expression test)
 399             ,(compile-expression then)
 400             ,(compile-expression else)))
 401
 402 (define-statement-operator if (test then &optional else)
 403   `(ps-js:if ,(compile-expression test)
 404              ,(compile-statement `(progn ,then))
 405              ,@(when else
 406                      `(:else ,(compile-statement `(progn ,else))))))
 407
 408 (define-expression-operator cond (&rest clauses)
 409   (compile-expression
 410    (when clauses
 411      (destructuring-bind (test &rest body) (car clauses)
 412        (if (eq t test)
 413            (if (null body) t `(progn ,@body))
 414            (flet ((conditional (test body)
 415                     `(if ,test
 416                          (progn ,@body)
 417                          (cond ,@(cdr clauses)))))
 418              (if (null body)
 419                  (with-ps-gensyms (test-result)
 420                    `(let ((,test-result ,test))
 421                       ,(conditional test-result (list test-result))))
 422                  (conditional test body))))))))
 423
 424 (define-statement-operator cond (&rest clauses)
 425   (let* ((test-result nil)
 426          (clauses*
 427            (loop for clause in clauses for (test . body) = clause
 428                  if body
 429                    collect clause
 430                  else
 431                    do (unless test-result (setq test-result (ps-gensym)))
 432                    and collect
 433                      (if (and (consp test) (eq (first test) 'return-from))
 434                          (cons `(setq ,test-result ,(third test))
 435                                `((return-from ,(second test) ,test-result)))
 436                          (cons `(setq ,test-result ,test)
 437                                `(,test-result)))))
 438          (if-form
 439            `(ps-js:if
 440               ,(compile-expression (caar clauses*))
 441               ,(compile-statement `(progn ,@(cdar clauses*)))
 442               ,@(loop for (test . body) in (cdr clauses*) appending
 443                   (if (eq t test)
 444                       `(:else ,(compile-statement `(progn ,@body)))
 445                       `(:else-if ,(compile-expression test)
 446                                  ,(compile-statement `(progn ,@body))))))))
 447     (if test-result
 448         `(ps-js:block (ps-js:var ,test-result) ,if-form)
 449         if-form)))
 450
 451 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 452 ;;; binding
 453
 454 (defmacro with-declaration-effects ((var block) &body body)
 455   (with-ps-gensyms (decls)
 456     `(multiple-value-bind (,var ,decls) (parse-body ,block)
 457        (let ((*special-variables*
 458               (nconc
 459                (loop for decl in ,decls nconc
 460                     (loop for (decl-type . decl-args) in (cdr decl)
 461                           if (eq decl-type 'special)
 462                           append decl-args))
 463                *special-variables*)))
 464          ,@body))))
 465
 466 (defun maybe-rename-lexical-var (x symbols-in-bindings)
 467   (when (or (member x *enclosing-lexicals*)
 468             (member x *enclosing-function-arguments*)
 469             (when (boundp '*used-up-names*)
 470               (member x *used-up-names*))
 471             (lookup-macro-def x *symbol-macro-env*)
 472             (member x symbols-in-bindings))
 473     (ps-gensym (symbol-name x))))
 474
 475 (defun with-lambda-scope (form)
 476   (prog1 (if (tree-find 'this
 477                         (let ((*ps-gensym-counter* *ps-gensym-counter*))
 478                           (ps-compile `(lambda () ,form))))
 479              `(funcall (getprop (lambda () ,form) 'call) this)
 480              `((lambda () ,form)))
 481     (setf *vars-needing-to-be-declared* ())))
 482
 483 (define-expression-operator let (bindings &body body)
 484   (with-declaration-effects (body body)
 485     (flet ((rename (x) (first x))
 486            (var    (x) (second x))
 487            (val    (x) (third x)))
 488       (let* ((new-lexicals ())
 489              (loop-scoped-lexicals ())
 490              (normalized-bindings
 491               (mapcar (lambda (x)
 492                         (if (symbolp x)
 493                             (list x nil)
 494                             (list (car x) (ps-macroexpand (cadr x)))))
 495                       bindings))
 496              (symbols-in-bindings
 497               (mapcan (lambda (x) (flatten (cadr x)))
 498                       normalized-bindings))
 499              (lexical-bindings
 500               (mapcan
 501                (lambda (x)
 502                  (unless (special-variable? (car x))
 503                    (let ((renamed (maybe-rename-lexical-var
 504                                    (car x) symbols-in-bindings)))
 505                      (if renamed
 506                          (when in-loop-scope?
 507                            (push renamed loop-scoped-lexicals))
 508                          (progn
 509                            (push (car x) new-lexicals)
 510                            (when (boundp '*used-up-names*)
 511                              (push (car x) *used-up-names*))))
 512                      (list (cons renamed x)))))
 513                normalized-bindings))
 514              (dynamic-bindings
 515               (loop for x in normalized-bindings
 516                     when (special-variable? (car x)) collect
 517                     (cons (ps-gensym (format nil "~A_~A" (car x) 'tmp-stack))
 518                           x)))
 519              (renamed-body
 520               `(symbol-macrolet ,(loop for x in lexical-bindings
 521                                        when (rename x) collect
 522                                        `(,(var x) ,(rename x)))
 523                  ,@body))
 524              (*enclosing-lexicals*
 525               (append new-lexicals *enclosing-lexicals*))
 526              (*loop-scope-lexicals*
 527               (when in-loop-scope?
 528                 (append new-lexicals loop-scoped-lexicals
 529                         *loop-scope-lexicals*)))
 530              (let-body
 531               `(progn
 532                  ,@(mapcar (lambda (x)
 533                              `(var ,(or (rename x) (var x)) ,(val x)))
 534                            lexical-bindings)
 535                  ,(if dynamic-bindings
 536                       `(progn
 537                          ,@(mapcar (lambda (x) `(var ,(rename x)))
 538                                    dynamic-bindings)
 539                          (try
 540                           (progn
 541                             (setf ,@(loop for x in dynamic-bindings append
 542                                          `(,(rename x) ,(var x)
 543                                             ,(var x) ,(val x))))
 544                             ,renamed-body)
 545                           (:finally
 546                            (setf ,@(mapcan (lambda (x) `(,(var x) ,(rename x)))
 547                                            dynamic-bindings)))))
 548                       renamed-body))))
 549           (ps-compile
 550            (cond ((or in-function-scope? (null bindings))
 551                   let-body)
 552                  ;; HACK
 553                  ((find-if
 554                    (lambda (x) (member x '(defun% defvar)))
 555                    (flatten
 556                     (loop for x in body collecting
 557                          (or (ignore-errors (ps-macroexpand x)) x))))
 558                   let-body)
 559                  (t
 560                   (with-lambda-scope let-body))))))))
 561
 562 (define-expression-operator locally (&rest body)
 563   (with-declaration-effects (body body)
 564     (ps-compile `(progn ,@body))))
 565
 566 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 567 ;;; macros
 568
 569 (defmacro with-local-macro-environment ((var env) &body body)
 570   `(let* ((,var (make-macro-dictionary))
 571           (,env (cons ,var ,env)))
 572      ,@body))
 573
 574 (define-expression-operator macrolet (macros &body body)
 575   (with-local-macro-environment (local-macro-dict *macro-env*)
 576     (dolist (macro macros)
 577       (destructuring-bind (name arglist &body body)
 578           macro
 579         (setf (gethash name local-macro-dict)
 580               (eval (make-ps-macro-function arglist body)))))
 581     (ps-compile `(locally ,@body))))
 582
 583 (define-expression-operator symbol-macrolet (symbol-macros &body body)
 584   (with-local-macro-environment (local-macro-dict *symbol-macro-env*)
 585     (with-declaration-effects (body body)
 586       (let (local-var-bindings)
 587         (dolist (macro symbol-macros)
 588           (destructuring-bind (name expansion) macro
 589             (setf (gethash name local-macro-dict) (lambda (x) (declare (ignore x)) expansion))
 590             (push name local-var-bindings)))
 591         (let ((*enclosing-lexicals* (append local-var-bindings *enclosing-lexicals*)))
 592           (ps-compile `(progn ,@body)))))))
 593
 594 (define-expression-operator defmacro (name args &body body)
 595   (eval `(defpsmacro ,name ,args ,@body))
 596   nil)
 597
 598 (define-expression-operator define-symbol-macro (name expansion)
 599   (eval `(define-ps-symbol-macro ,name ,expansion))
 600   nil)
 601
 602 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 603 ;;; assignment
 604
 605 (defun assignment-op (op)
 606   (getf '(ps-js:+   ps-js:+=
 607           ps-js:~   ps-js:~=
 608           ps-js:&   ps-js:&=
 609           ps-js:-   ps-js:-=
 610           ps-js:*   ps-js:*=
 611           ps-js:%   ps-js:%=
 612           ps-js:>>  ps-js:>>=
 613           ps-js:^   ps-js:^=
 614           ps-js:<<  ps-js:<<=
 615           ps-js:>>> ps-js:>>>=
 616           ps-js:/   ps-js:/=)
 617         op))
 618
 619 (define-expression-operator ps-assign (lhs rhs)
 620   (let ((rhs (ps-macroexpand rhs)))
 621     (if (and (listp rhs) (eq (car rhs) 'progn))
 622         (ps-compile `(progn ,@(butlast (cdr rhs))
 623                             (ps-assign ,lhs ,(car (last (cdr rhs))))))
 624         (let ((lhs (compile-expression lhs))
 625               (rhs (compile-expression rhs)))
 626           (aif (and (listp rhs)
 627                     (= 3 (length rhs))
 628                     (equal lhs (second rhs))
 629                     (assignment-op (first rhs)))
 630                (list it lhs (if (fourth rhs)
 631                                 (cons (first rhs) (cddr rhs))
 632                                 (third rhs)))
 633                (list 'ps-js:= lhs rhs))))))
 634
 635 (define-statement-operator defvar (name &optional
 636                                         (value (values) value-provided?)
 637                                         documentation)
 638   ;; this must be used as a top-level form, otherwise the resulting
 639   ;; behavior will be undefined.
 640   (declare (ignore documentation)) ; TODO: print docstring
 641   (pushnew name *special-variables*)
 642
 643   (ps-compile (if value-provided?
 644                   `(when (undefined ,name) (var ,name ,value))
 645                   (list 'var name))))
 646
 647 (define-statement-operator defparameter
 648     (name &optional (value (values) value-provided?) documentation)
 649   ;; this must be used as a top-level form, otherwise the resulting
 650   ;; behavior will be undefined.
 651   (declare (ignore documentation)) ; TODO: print docstring
 652   (pushnew name *special-variables*)
 653   (ps-compile `(var ,name ,@(when value-provided? (list value)))))
 654
 655 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 656 ;;; iteration
 657
 658 (defun make-for-vars/inits (init-forms)
 659   (mapcar (lambda (x)
 660             (cons (ps-macroexpand (if (atom x) x (first x)))
 661                   (compile-expression (if (atom x) nil (second x)))))
 662           init-forms))
 663
 664 (defun compile-loop-body (loop-vars body)
 665   (let (compiled-body loop-closures?)
 666     (let* ((in-loop-scope?                 t)
 667            (*loop-scope-lexicals*          ())
 668            (*loop-scope-lexicals-captured* ())
 669            (*ps-gensym-counter*            *ps-gensym-counter*))
 670       (setf compiled-body  (compile-statement `(progn ,@body))
 671             loop-closures? *loop-scope-lexicals-captured*))
 672     (if loop-closures?
 673         (compile-statement `(progn ((lambda () ,@body))))
 674         compiled-body)))
 675
 676 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 677 ;;; evaluation
 678
 679 (define-expression-operator quote (x)
 680   (flet ((quote% (expr) (when expr `',expr)))
 681     (compile-expression
 682      (typecase x
 683        (cons `(array ,@(mapcar #'quote% x)))
 684        ((or null (eql [])) '(array))
 685        (keyword x)
 686        (symbol (symbol-to-js-string x))
 687        (number x)
 688        (string x)
 689        (vector `(array ,@(loop for el across x collect (quote% el))))))))
 690
 691 (define-expression-operator eval-when (situation-list &body body)
 692   "The body is evaluated only during the given situations. The
 693 accepted situations are :load-toplevel, :compile-toplevel,
 694 and :execute. The code in BODY is assumed to be Common Lisp code
 695 in :compile-toplevel and :load-toplevel sitations, and Parenscript
 696 code in :execute."
 697   (when (and (member :compile-toplevel situation-list)
 698              (member *compilation-level* '(:toplevel :inside-toplevel-form)))
 699     (eval `(progn ,@body)))
 700   (if (member :execute situation-list)
 701       (ps-compile `(progn ,@body))
 702       (ps-compile `(progn))))