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            `(ps-js:block
 180                (ps-js:try
 181                 ,body
 182                 :catch (,_ps_err
 183                         ,(compile-statement
 184                           `(progn (cond
 185                                     ,@(mapcar #'make-catch-clause it)
 186                                     (t (throw ,_ps_err))))))
 187                 :finally nil))))
 188        body))
 189
 190 (define-statement-operator block (name &rest body)
 191   (if in-function-scope?
 192       (let* ((name                  (or name 'nilBlock))
 193              (in-loop-scope?        (if name in-loop-scope? nil))
 194              (*dynamic-return-tags* (cons (cons name nil)
 195                                           *dynamic-return-tags*))
 196              (*current-block-tag*   name)
 197              (compiled-body         (wrap-for-dynamic-return
 198                                      (list name)
 199                                      (ps-compile `(progn ,@body)))))
 200         ;; this probably does not nest correctly
 201         (if (tree-find `(ps-js:break ,name) compiled-body)
 202             `(ps-js:label ,name ,compiled-body)
 203             compiled-body))
 204       (ps-compile (with-lambda-scope `(block ,name ,@body)))))
 205
 206 (define-expression-operator values (&rest forms)
 207   (ps-compile
 208    (with-ps-gensyms (val)
 209      `(let ((,val ,(car forms)))
 210         (setf __PS_MV_REG (list ,@(cdr forms)))
 211         ,val))))
 212
 213 (define-expression-operator values-list (list)
 214   (ps-compile
 215    (with-ps-gensyms (values-list firstval)
 216      `(let ((,values-list (funcall (getprop ,list 'slice))))
 217         (setf ,firstval   (funcall (getprop ,values-list 'shift))
 218               __PS_MV_REG ,values-list)
 219         ,firstval))))
 220
 221 (define-statement-operator %simple-lexical-return (&rest value)
 222   `(ps-js:return ,@value))
 223
 224 (defun return-exp (tag &optional (value nil value?))
 225   (flet ((lexical-return ()
 226            (let ((X (when value? (list (compile-expression value)))))
 227              (ps-compile
 228               (if (and (not returning-values?) clear-multiple-values?)
 229                   `(progn
 230                      (setf __PS_MV_REG (list))
 231                      (%simple-lexical-return ,@X))
 232                   `(%simple-lexical-return ,@X))))))
 233     (acond
 234       ((eql tag *current-block-tag*)
 235        (compile-statement
 236         `(progn
 237            ,@(when (and (not returning-values?) clear-multiple-values?)
 238                '((setf __PS_MV_REG '())))
 239            ,@(when value? (list value))
 240            (break ,tag))))
 241
 242       ((or (eql '%function tag)
 243            (member tag *function-block-names*))
 244        (lexical-return))
 245
 246       ((assoc tag *dynamic-return-tags*)
 247        (setf (cdr it) t)
 248        (ps-compile
 249         `(progn
 250            ,@(when (and (not returning-values?) clear-multiple-values?)
 251                '((setf __PS_MV_REG '())))
 252            (throw (create
 253                    :__ps_block_tag ',tag
 254                    :__ps_value     ,value)))))
 255
 256       (t
 257        (warn "Returning from unknown block ~A" tag)
 258        (lexical-return)))))
 259
 260 (defun try-expressionizing-if? (exp &optional (score 0)) ;; poor man's codewalker
 261   "Heuristic that tries not to expressionize deeply nested if expressions."
 262   (cond ((< 1 score) nil)
 263         ((and (listp exp) (eq (car exp) 'quote))
 264          t)
 265         ((listp exp)
 266          (loop for x in (cdr exp) always
 267               (try-expressionizing-if?
 268                (or (ignore-errors (ps-macroexpand x))
 269                    x) ;; fail
 270                (+ score (case (car exp)
 271                           ((if cond) 1)
 272                           (let (if (second exp) 1 0)) ;; ignore empty binding list
 273                           ((progn) (1- (length (cdr exp))))
 274                           (otherwise 0))))))
 275         (t t)))
 276
 277 (defun return-result-of (tag form)
 278   (ps-compile
 279    (case (car form)
 280      ((continue break throw) ;; non-local exit
 281       form)
 282      ;; implicit progn forms
 283      ((with) ;; deprecated and will be removed
 284       `(,(first form) ,(second form)
 285          ,@(butlast (cddr form))
 286          (return-from ,tag ,(car (last (cddr form))))))
 287      ;; implicit body (declaration + progn) forms
 288      ((let flet labels macrolet symbol-macrolet)
 289       (multiple-value-bind (body declarations)
 290           (parse-body (cddr form))
 291         `(,(first form) ,(second form)
 292            ,@declarations
 293            ,@(butlast body)
 294            (return-from ,tag ,(car (last body))))))
 295      ((progn locally)
 296        `(progn ,@(butlast (cdr form))
 297                (return-from ,tag ,(car (last (cdr form))))))
 298      (switch
 299       `(switch
 300         ,(second form)
 301         ,@(loop for (cvalue . cbody) in (cddr form)
 302                 for remaining on (cddr form) collect
 303                 (aif (cond ((or (eq 'default cvalue) (not (cdr remaining)))
 304                             1)
 305                            ((eq 'break (car (last cbody)))
 306                             2))
 307                      (let ((result-form (ps-macroexpand
 308                                          (car (last cbody it)))))
 309                        `(,cvalue
 310                          ,@(butlast cbody it)
 311                          (return-from ,tag
 312                            ,(if (eq result-form 'break) nil result-form))))
 313                      (cons cvalue cbody)))))
 314      (try
 315       `(try (return-from ,tag ,(second form))
 316             ,@(let ((catch (cdr (assoc :catch (cdr form))))
 317                     (finally (assoc :finally (cdr form))))
 318                    (list (when catch
 319                            `(:catch ,(car catch)
 320                               ,@(butlast (cdr catch))
 321                               (return-from ,tag
 322                                 ,(car (last (cdr catch))))))
 323                          finally))))
 324      (cond
 325        `(cond
 326           ,@(loop for clause in (cdr form) collect
 327                   `(,@(butlast clause) (return-from ,tag ,(car (last clause)))))
 328           ,@(when in-case? `((t (return-from ,tag nil))))))
 329      (if
 330       (if (and (try-expressionizing-if? form)
 331                (not (tree-find 'values form))
 332                (let ((used-up-names                   *used-up-names*)
 333                      (*lambda-wrappable-statements*                ()))
 334                  (handler-case (compile-expression form)
 335                    (compile-expression-error ()
 336                      (setf *used-up-names* used-up-names)
 337                      nil))))
 338           (return-from return-result-of (return-exp tag form))
 339           `(if ,(second form)
 340                (return-from ,tag ,(third form))
 341                ,@(when (or in-case? (fourth form))
 342                    `((return-from ,tag ,(fourth form)))))))
 343      (block
 344       (let* ((tag₁                   (or (cadr form) 'nilBlock))
 345              (*function-block-names* (cons tag₁ *function-block-names*))
 346              (*dynamic-return-tags*  (cons (cons tag₁ nil)
 347                                            *dynamic-return-tags*)))
 348         (return-from return-result-of
 349           (wrap-for-dynamic-return
 350            (list tag₁)
 351            (ps-compile `(return-from ,tag (progn ,@(cddr form))))))))
 352      (values
 353       (if (cddr form)
 354           (with-ps-gensyms (val)
 355             `(let ((,val ,(cadr form)))
 356                (setf __PS_MV_REG (list ,@(cddr form)))
 357                (return-from ,tag ,val t)))
 358           `(return-from ,tag ,@(cdr form))))
 359      (values-list
 360       (with-ps-gensyms (values-list firstval)
 361         `(let ((,values-list (funcall (getprop ,(cadr form) 'slice))))
 362            (setf ,firstval   (funcall (getprop ,values-list 'shift))
 363                  __PS_MV_REG ,values-list)
 364            (return-from ,tag ,firstval t))))
 365      (return-from ;; this will go away someday
 366       (unless tag
 367         (warn 'simple-style-warning
 368               :format-control "Trying to RETURN a RETURN without a block tag specified. Perhaps you're still returning values from functions by hand?
 369 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."))
 370        form)
 371      (otherwise
 372       (return-from return-result-of
 373         (cond ((not (gethash (car form) *special-statement-operators*))
 374                (return-exp tag form))
 375               (in-case?
 376                `(ps-js:block ,(compile-statement form) ,(return-exp tag)))
 377               (t (compile-statement form))))))))
 378
 379 (define-statement-operator return-from (tag &optional
 380                                             (result nil result?)
 381                                             returning-values?)
 382   (setq tag (or tag 'nilBlock))
 383   (if result?
 384       (let ((form (ps-macroexpand result)))
 385         (if (atom form)
 386             (return-exp tag form)
 387             (return-result-of tag form)))
 388       (return-exp tag)))
 389
 390 (define-statement-operator throw (&rest args)
 391   `(ps-js:throw ,@(mapcar #'compile-expression args)))
 392
 393 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 394 ;;; conditionals
 395
 396 (define-expression-operator if (test then &optional else)
 397   `(ps-js:? ,(compile-expression test)
 398             ,(compile-expression then)
 399             ,(compile-expression else)))
 400
 401 (define-statement-operator if (test then &optional else)
 402   `(ps-js:if ,(compile-expression test)
 403              ,(compile-statement `(progn ,then))
 404              ,@(when else
 405                      `(:else ,(compile-statement `(progn ,else))))))
 406
 407 (define-expression-operator cond (&rest clauses)
 408   (compile-expression
 409    (when clauses
 410      (destructuring-bind (test &rest body) (car clauses)
 411        (if (eq t test)
 412            (if (null body) t `(progn ,@body))
 413            (flet ((conditional (test body)
 414                     `(if ,test
 415                          (progn ,@body)
 416                          (cond ,@(cdr clauses)))))
 417              (if (null body)
 418                  (with-ps-gensyms (test-result)
 419                    `(let ((,test-result ,test))
 420                       ,(conditional test-result (list test-result))))
 421                  (conditional test body))))))))
 422
 423 (define-statement-operator cond (&rest clauses)
 424   (let* ((test-result nil)
 425          (clauses*
 426            (loop for clause in clauses for (test . body) = clause
 427                  if body
 428                    collect clause
 429                  else
 430                    do (unless test-result (setq test-result (ps-gensym)))
 431                    and collect
 432                      (if (and (consp test) (eq (first test) 'return-from))
 433                          (cons `(setq ,test-result ,(third test))
 434                                `((return-from ,(second test) ,test-result)))
 435                          (cons `(setq ,test-result ,test)
 436                                `(,test-result)))))
 437          (if-form
 438            `(ps-js:if
 439               ,(compile-expression (caar clauses*))
 440               ,(compile-statement `(progn ,@(cdar clauses*)))
 441               ,@(loop for (test . body) in (cdr clauses*) appending
 442                   (if (eq t test)
 443                       `(:else ,(compile-statement `(progn ,@body)))
 444                       `(:else-if ,(compile-expression test)
 445                                  ,(compile-statement `(progn ,@body))))))))
 446     (if test-result
 447         `(ps-js:block (ps-js:var ,test-result) ,if-form)
 448         if-form)))
 449
 450 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 451 ;;; binding
 452
 453 (defmacro with-declaration-effects ((var block) &body body)
 454   (with-ps-gensyms (decls)
 455     `(multiple-value-bind (,var ,decls) (parse-body ,block)
 456        (let ((*special-variables*
 457               (nconc
 458                (loop for decl in ,decls nconc
 459                     (loop for (decl-type . decl-args) in (cdr decl)
 460                           if (eq decl-type 'special)
 461                           append decl-args))
 462                *special-variables*)))
 463          ,@body))))
 464
 465 (defun maybe-rename-lexical-var (x symbols-in-bindings)
 466   (when (or (member x *enclosing-lexicals*)
 467             (member x *enclosing-function-arguments*)
 468             (when (boundp '*used-up-names*)
 469               (member x *used-up-names*))
 470             (lookup-macro-def x *symbol-macro-env*)
 471             (member x symbols-in-bindings))
 472     (ps-gensym (symbol-name x))))
 473
 474 (defun with-lambda-scope (form)
 475   (prog1 (if (tree-find 'this
 476                         (let ((*ps-gensym-counter* *ps-gensym-counter*))
 477                           (ps-compile `(lambda () ,form))))
 478              `(funcall (getprop (lambda () ,form) 'call) this)
 479              `((lambda () ,form)))
 480     (setf *vars-needing-to-be-declared* ())))
 481
 482 (define-expression-operator let (bindings &body body)
 483   (with-declaration-effects (body body)
 484     (flet ((rename (x) (first x))
 485            (var    (x) (second x))
 486            (val    (x) (third x)))
 487       (let* ((new-lexicals ())
 488              (loop-scoped-lexicals ())
 489              (normalized-bindings
 490               (mapcar (lambda (x)
 491                         (if (symbolp x)
 492                             (list x nil)
 493                             (list (car x) (ps-macroexpand (cadr x)))))
 494                       bindings))
 495              (symbols-in-bindings
 496               (mapcan (lambda (x) (flatten (cadr x)))
 497                       normalized-bindings))
 498              (lexical-bindings
 499               (mapcan
 500                (lambda (x)
 501                  (unless (special-variable? (car x))
 502                    (let ((renamed (maybe-rename-lexical-var
 503                                    (car x) symbols-in-bindings)))
 504                      (if renamed
 505                          (when in-loop-scope?
 506                            (push renamed loop-scoped-lexicals))
 507                          (progn
 508                            (push (car x) new-lexicals)
 509                            (when (boundp '*used-up-names*)
 510                              (push (car x) *used-up-names*))))
 511                      (list (cons renamed x)))))
 512                normalized-bindings))
 513              (dynamic-bindings
 514               (loop for x in normalized-bindings
 515                     when (special-variable? (car x)) collect
 516                     (cons (ps-gensym (format nil "~A_~A" (car x) 'tmp-stack))
 517                           x)))
 518              (renamed-body
 519               `(symbol-macrolet ,(loop for x in lexical-bindings
 520                                        when (rename x) collect
 521                                        `(,(var x) ,(rename x)))
 522                  ,@body))
 523              (*enclosing-lexicals*
 524               (append new-lexicals *enclosing-lexicals*))
 525              (*loop-scope-lexicals*
 526               (when in-loop-scope?
 527                 (append new-lexicals loop-scoped-lexicals
 528                         *loop-scope-lexicals*)))
 529              (let-body
 530               `(progn
 531                  ,@(mapcar (lambda (x)
 532                              `(var ,(or (rename x) (var x)) ,(val x)))
 533                            lexical-bindings)
 534                  ,(if dynamic-bindings
 535                       `(progn
 536                          ,@(mapcar (lambda (x) `(var ,(rename x)))
 537                                    dynamic-bindings)
 538                          (try
 539                           (progn
 540                             (setf ,@(loop for x in dynamic-bindings append
 541                                          `(,(rename x) ,(var x)
 542                                             ,(var x) ,(val x))))
 543                             ,renamed-body)
 544                           (:finally
 545                            (setf ,@(mapcan (lambda (x) `(,(var x) ,(rename x)))
 546                                            dynamic-bindings)))))
 547                       renamed-body))))
 548           (ps-compile
 549            (cond ((or in-function-scope? (null bindings))
 550                   let-body)
 551                  ;; HACK
 552                  ((find-if
 553                    (lambda (x) (member x '(defun% defvar)))
 554                    (flatten
 555                     (loop for x in body collecting
 556                          (or (ignore-errors (ps-macroexpand x)) x))))
 557                   let-body)
 558                  (t
 559                   (with-lambda-scope let-body))))))))
 560
 561 (define-expression-operator locally (&rest body)
 562   (with-declaration-effects (body body)
 563     (ps-compile `(progn ,@body))))
 564
 565 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 566 ;;; macros
 567
 568 (defmacro with-local-macro-environment ((var env) &body body)
 569   `(let* ((,var (make-macro-dictionary))
 570           (,env (cons ,var ,env)))
 571      ,@body))
 572
 573 (define-expression-operator macrolet (macros &body body)
 574   (with-local-macro-environment (local-macro-dict *macro-env*)
 575     (dolist (macro macros)
 576       (destructuring-bind (name arglist &body body)
 577           macro
 578         (setf (gethash name local-macro-dict)
 579               (eval (make-ps-macro-function arglist body)))))
 580     (ps-compile `(locally ,@body))))
 581
 582 (define-expression-operator symbol-macrolet (symbol-macros &body body)
 583   (with-local-macro-environment (local-macro-dict *symbol-macro-env*)
 584     (with-declaration-effects (body body)
 585       (let (local-var-bindings)
 586         (dolist (macro symbol-macros)
 587           (destructuring-bind (name expansion) macro
 588             (setf (gethash name local-macro-dict) (lambda (x) (declare (ignore x)) expansion))
 589             (push name local-var-bindings)))
 590         (let ((*enclosing-lexicals* (append local-var-bindings *enclosing-lexicals*)))
 591           (ps-compile `(progn ,@body)))))))
 592
 593 (define-expression-operator defmacro (name args &body body)
 594   (eval `(defpsmacro ,name ,args ,@body))
 595   nil)
 596
 597 (define-expression-operator define-symbol-macro (name expansion)
 598   (eval `(define-ps-symbol-macro ,name ,expansion))
 599   nil)
 600
 601 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 602 ;;; assignment
 603
 604 (defun assignment-op (op)
 605   (getf '(ps-js:+   ps-js:+=
 606           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         op))
 617
 618 (define-expression-operator ps-assign (lhs rhs)
 619   (let ((rhs (ps-macroexpand rhs)))
 620     (if (and (listp rhs) (eq (car rhs) 'progn))
 621         (ps-compile `(progn ,@(butlast (cdr rhs))
 622                             (ps-assign ,lhs ,(car (last (cdr rhs))))))
 623         (let ((lhs (compile-expression lhs))
 624               (rhs (compile-expression rhs)))
 625           (aif (and (listp rhs)
 626                     (= 3 (length rhs))
 627                     (equal lhs (second rhs))
 628                     (assignment-op (first rhs)))
 629                (list it lhs (if (fourth rhs)
 630                                 (cons (first rhs) (cddr rhs))
 631                                 (third rhs)))
 632                (list 'ps-js:= lhs rhs))))))
 633
 634 (define-statement-operator defvar (name &optional
 635                                         (value (values) value-provided?)
 636                                         documentation)
 637   ;; this must be used as a top-level form, otherwise the resulting
 638   ;; behavior will be undefined.
 639   (declare (ignore documentation)) ; TODO: print docstring
 640   (pushnew name *special-variables*)
 641
 642   (ps-compile (if value-provided?
 643                   `(when (undefined ,name) (var ,name ,value))
 644                   (list 'var name))))
 645
 646 (define-statement-operator defparameter
 647     (name &optional (value (values) value-provided?) documentation)
 648   ;; this must be used as a top-level form, otherwise the resulting
 649   ;; behavior will be undefined.
 650   (declare (ignore documentation)) ; TODO: print docstring
 651   (pushnew name *special-variables*)
 652   (ps-compile `(var ,name ,@(when value-provided? (list value)))))
 653
 654 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 655 ;;; iteration
 656
 657 (defun make-for-vars/inits (init-forms)
 658   (mapcar (lambda (x)
 659             (cons (ps-macroexpand (if (atom x) x (first x)))
 660                   (compile-expression (if (atom x) nil (second x)))))
 661           init-forms))
 662
 663 (defun compile-loop-body (loop-vars body)
 664   (let (compiled-body loop-closures?)
 665     (let* ((in-loop-scope?                 t)
 666            (*loop-scope-lexicals*          ())
 667            (*loop-scope-lexicals-captured* ())
 668            (*ps-gensym-counter*            *ps-gensym-counter*))
 669       (setf compiled-body  (compile-statement `(progn ,@body))
 670             loop-closures? *loop-scope-lexicals-captured*))
 671     (if loop-closures?
 672         (compile-statement `(progn ((lambda () ,@body))))
 673         compiled-body)))
 674
 675 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 676 ;;; evaluation
 677
 678 (define-expression-operator quote (x)
 679   (flet ((quote% (expr) (when expr `',expr)))
 680     (compile-expression
 681      (typecase x
 682        (cons `(array ,@(mapcar #'quote% x)))
 683        ((or null (eql [])) '(array))
 684        (keyword x)
 685        (symbol (symbol-to-js-string x))
 686        (number x)
 687        (string x)
 688        (vector `(array ,@(loop for el across x collect (quote% el))))))))
 689
 690 (define-expression-operator eval-when (situation-list &body body)
 691   "The body is evaluated only during the given situations. The
 692 accepted situations are :load-toplevel, :compile-toplevel,
 693 and :execute. The code in BODY is assumed to be Common Lisp code
 694 in :compile-toplevel and :load-toplevel sitations, and Parenscript
 695 code in :execute."
 696   (when (and (member :compile-toplevel situation-list)
 697              (member *compilation-level* '(:toplevel :inside-toplevel-form)))
 698     (eval `(progn ,@body)))
 699   (if (member :execute situation-list)
 700       (ps-compile `(progn ,@body))
 701       (ps-compile `(progn))))