src/special-operators.lisp

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