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