src/special-forms.lisp

   1 (in-package "PARENSCRIPT")
   2
   3 (defmacro with-local-macro-environment ((var env) &body body)
   4   `(let* ((,var (make-macro-dictionary))
   5           (,env (cons ,var ,env)))
   6      ,@body))
   7
   8 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9 ;;; literals
  10 (defmacro defpsliteral (name string)
  11   `(progn
  12      (add-ps-reserved-symbol ',name)
  13      (define-ps-special-form ,name ()
  14        (list 'js:literal ,string))))
  15
  16 (defpsliteral this      "this")
  17 (defpsliteral t         "true")
  18 (defpsliteral true      "true")
  19 (defpsliteral false     "false")
  20 (defpsliteral f         "false")
  21 (defpsliteral nil       "null")
  22 (defpsliteral undefined "undefined")
  23
  24 (macrolet ((def-for-literal (name printer)
  25              `(progn
  26                 (add-ps-reserved-symbol ',name)
  27                 (define-ps-special-form ,name (&optional label)
  28                   (list ',printer label)))))
  29   (def-for-literal break js:break)
  30   (def-for-literal continue js:continue))
  31
  32 (define-ps-special-form quote (x)
  33   (flet ((quote% (expr) (when expr `',expr)))
  34     (ps-compile-expression
  35      (typecase x
  36        (cons `(array ,@(mapcar #'quote% x)))
  37        (null '(array))
  38        (keyword x)
  39        (symbol (symbol-to-js-string x))
  40        (number x)
  41        (string x)
  42        (vector `(array ,@(loop :for el :across x :collect (quote% el))))))))
  43
  44 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  45 ;;; unary operators
  46 (macrolet ((def-unary-ops (&rest ops)
  47              `(progn ,@(mapcar (lambda (op)
  48                                  (let ((op (if (listp op) (car op) op))
  49                                        (spacep (if (listp op) (second op) nil)))
  50                                    `(define-ps-special-form ,op (x)
  51                                       (list 'js:unary-operator ',op
  52                                             (ps-compile-expression (ps-macroexpand x))
  53                                             :prefix t :space ,spacep))))
  54                                ops))))
  55   (def-unary-ops ~ ! (new t) (delete t) (void t) (typeof t)))
  56
  57 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  58 ;;; statements
  59
  60 (defun ps-statement? (exp)
  61   (and (consp exp)
  62        (member (car exp)
  63                '(throw
  64                  do
  65                  do*
  66                  dotimes
  67                  dolist
  68                  for-in
  69                  while))))
  70
  71 (defun implicit-progn-form? (form)
  72   (member (car form) '(with progn let flet labels macrolet symbol-macrolet)))
  73
  74 (define-ps-special-form return (&optional value)
  75   (let ((value (ps-macroexpand value)))
  76     (if (ps-statement? value)
  77         (ps-compile-statement value)
  78         (if (consp value)
  79             (if (implicit-progn-form? value)
  80                 (ps-compile (append (butlast value)
  81                                     `((return ,@(last value)))))
  82                 (case (car value)
  83                   (return
  84                     (ps-compile value))
  85                   (switch
  86                    (ps-compile
  87                     `(js:switch ,(second value)
  88                                 ,@(loop for (cvalue . cbody) in (cddr value)
  89                                      for remaining on (cddr value) collect
  90                                        (let ((last-n
  91                                               (cond ((or (eq 'js:default cvalue)
  92                                                          (not (cdr remaining)))
  93                                                      1)
  94                                                     ((eq 'js:break
  95                                                          (car (last cbody)))
  96                                                      2))))
  97                                          (if last-n
  98                                              `(,cvalue
  99                                                ,@(butlast cbody last-n)
 100                                                (return
 101                                                  ,(car (last cbody last-n))))
 102                                              (cons cvalue cbody)))))))
 103                   (try
 104                    (ps-compile `(try (return ,(second value))
 105                                      ,@(cddr value))))
 106                   (if
 107                    (ps-compile `(if ,(second value)
 108                                     (return ,(third value))
 109                                     (return ,(fourth value)))))
 110                   (cond
 111                     (ps-compile `(cond
 112                                    ,@(loop for clause in (cdr value) collect
 113                                           `(,@(butlast clause)
 114                                               (return ,@(last clause)))))))
 115                   (otherwise
 116                    `(js:return ,(ps-compile-expression value)))))
 117             `(js:return ,(ps-compile-expression value))))))
 118
 119 (defpsmacro values (&optional main &rest additional)
 120   (when main
 121     (if additional
 122         (with-ps-gensyms (val1 valrest)
 123           `(let ((,val1 ,main)
 124                  (,valrest (list ,@additional)))
 125              (when (defined (@ arguments :callee :caller :mv))
 126                (setf (@ arguments :callee :caller :mv) ,valrest))
 127              ,val1))
 128         main)))
 129
 130 (defpsmacro multiple-value-bind (vars expr &body body)
 131   (let ((expr (ps-macroexpand expr)))
 132     (if (and (consp expr) (implicit-progn-form? expr))
 133         `(,@(butlast expr)
 134             (multiple-value-bind ,vars
 135                 ,@(last expr)
 136               ,@body))
 137         (with-ps-gensyms (mv prev-mv)
 138           `(let ((,prev-mv (@ arguments :callee :mv)))
 139              (try
 140               (progn
 141                 (setf (@ arguments :callee :mv) t)
 142                 (let ((,(car vars) ,expr)
 143                       (,mv (if (objectp (@ arguments :callee :mv))
 144                                (@ arguments :callee :mv)
 145                                (make-array ,(1- (length vars))))))
 146                   (destructuring-bind ,(cdr vars) ,mv
 147                     ,@body)))
 148               (:finally (if (undefined ,prev-mv)
 149                             (delete (@ arguments :callee :mv))
 150                             (setf (@ arguments :callee :mv) ,prev-mv)))))))))
 151
 152 (define-ps-special-form throw (value)
 153   `(js:throw ,(ps-compile-expression (ps-macroexpand value))))
 154
 155 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 156 ;;; arrays
 157 (define-ps-special-form array (&rest values)
 158   `(js:array ,@(mapcar (lambda (form) (ps-compile-expression (ps-macroexpand form)))
 159                        values)))
 160
 161 (define-ps-special-form aref (array &rest coords)
 162   `(js:aref ,(ps-compile-expression (ps-macroexpand array))
 163             ,(mapcar (lambda (form)
 164                        (ps-compile-expression (ps-macroexpand form)))
 165                      coords)))
 166
 167 (defpsmacro list (&rest values)
 168   `(array ,@values))
 169
 170 (defpsmacro make-array (&rest initial-values)
 171   `(new (*array ,@initial-values)))
 172
 173 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 174 ;;; operators
 175 (define-ps-special-form incf (x &optional (delta 1))
 176   (let ((x (ps-macroexpand x))
 177         (delta (ps-macroexpand delta)))
 178     (if (eql delta 1)
 179         `(js:unary-operator js:++ ,(ps-compile-expression x) :prefix t)
 180         `(js:operator js:+= ,(ps-compile-expression x)
 181                       ,(ps-compile-expression delta)))))
 182
 183 (define-ps-special-form decf (x &optional (delta 1))
 184   (let ((x (ps-macroexpand x))
 185         (delta (ps-macroexpand delta)))
 186     (if (eql delta 1)
 187         `(js:unary-operator js:-- ,(ps-compile-expression x) :prefix t)
 188         `(js:operator js:-= ,(ps-compile-expression x)
 189                       ,(ps-compile-expression delta)))))
 190
 191 (define-ps-special-form - (first &rest rest)
 192   (let ((first (ps-macroexpand first))
 193         (rest (mapcar #'ps-macroexpand rest)))
 194     (if rest
 195         `(js:operator js:- ,@(mapcar (lambda (val) (ps-compile-expression val))
 196                                      (cons first rest)))
 197         `(js:unary-operator js:- ,(ps-compile-expression first) :prefix t))))
 198
 199 (define-ps-special-form not (x)
 200   (let ((form (ps-compile-expression (ps-macroexpand x)))
 201         inverse-op)
 202     (cond ((and (eq (car form) 'js:unary-operator)
 203                 (eq (second form) '!))
 204            (third form))
 205           ((and (eq (car form) 'js:operator)
 206                 (= (length (cddr form)) 2)
 207                 (setf inverse-op (case (cadr form)
 208                                    (== '!=)
 209                                    (< '>=)
 210                                    (> '<=)
 211                                    (<= '>)
 212                                    (>= '<)
 213                                    (!= '==)
 214                                    (=== '!==)
 215                                    (!== '===))))
 216            `(js:operator ,inverse-op ,@(cddr form)))
 217           (t `(js:unary-operator js:! ,form :prefix t)))))
 218
 219 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 220 ;;; control structures
 221 (defun flatten-blocks (body)
 222   (when body
 223     (if (and (listp (car body))
 224              (eq 'js:block (caar body)))
 225         (append (cdr (car body)) (flatten-blocks (cdr body)))
 226         (cons (car body) (flatten-blocks (cdr body))))))
 227
 228 (defun constant-literal-form-p (form)
 229   (or (numberp form)
 230       (stringp form)
 231       (and (listp form)
 232            (eq 'js:literal (car form)))))
 233
 234 (define-ps-special-form progn (&rest body)
 235   (let ((body (mapcar #'ps-macroexpand body)))
 236     (if (and compile-expression? (= 1 (length body)))
 237         (ps-compile-expression (car body))
 238         `(,(if compile-expression? 'js:|,| 'js:block)
 239            ,@(let* ((block (flatten-blocks (remove nil (mapcar #'ps-compile body)))))
 240                    (append (remove-if #'constant-literal-form-p (butlast block)) (last block)))))))
 241
 242 (define-ps-special-form cond (&rest clauses)
 243   (if compile-expression?
 244       (make-cond-clauses-into-nested-ifs clauses)
 245       `(js:if ,(ps-compile-expression (caar clauses))
 246               ,(ps-compile-statement `(progn ,@(cdar clauses)))
 247               ,@(loop for (test . body) in (cdr clauses) appending
 248                      (if (eq t test)
 249                          `(:else ,(ps-compile-statement `(progn ,@body)))
 250                          `(:else-if ,(ps-compile-expression test)
 251                                     ,(ps-compile-statement `(progn ,@body))))))))
 252
 253 (defun make-cond-clauses-into-nested-ifs (clauses)
 254   (if clauses
 255       (destructuring-bind (test &rest body)
 256           (car clauses)
 257         (if (eq t test)
 258             (ps-compile-expression `(progn ,@body))
 259             `(js:? ,(ps-compile-expression test)
 260                    ,(ps-compile-expression `(progn ,@body))
 261                    ,(make-cond-clauses-into-nested-ifs (cdr clauses)))))
 262       (ps-compile-expression nil)))
 263
 264 (define-ps-special-form if (test then &optional else)
 265   (if compile-expression?
 266       `(js:? ,(ps-compile-expression (ps-macroexpand test))
 267              ,(ps-compile-expression (ps-macroexpand then))
 268              ,(ps-compile-expression (ps-macroexpand else)))
 269       `(js:if ,(ps-compile-expression (ps-macroexpand test))
 270               ,(ps-compile-statement `(progn ,then))
 271               ,@(when else `(:else ,(ps-compile-statement `(progn ,else)))))))
 272
 273 (define-ps-special-form switch (test-expr &rest clauses)
 274   `(js:switch ,(ps-compile-expression test-expr)
 275      ,(loop for (val . body) in clauses collect
 276            (cons (if (eq val 'default)
 277                      'default
 278                      (ps-compile-expression val))
 279                  (mapcan (lambda (x)
 280                            (let ((exp (ps-compile-statement x)))
 281                              (if (and (listp exp) (eq 'js:block (car exp)))
 282                                  (cdr exp)
 283                                  (list exp))))
 284                          body)))))
 285
 286 (defpsmacro case (value &rest clauses)
 287   (labels ((make-clause (val body more)
 288              (cond ((and (listp val) (not (eq (car val) 'quote)))
 289                     (append (mapcar #'list (butlast val))
 290                             (make-clause (first (last val)) body more)))
 291                    ((member val '(t otherwise))
 292                     (make-clause 'default body more))
 293                    (more `((,val ,@body break)))
 294                    (t `((,val ,@body))))))
 295     `(switch ,value ,@(mapcon (lambda (clause)
 296                                 (make-clause (car (first clause))
 297                                              (cdr (first clause))
 298                                              (rest clause)))
 299                               clauses))))
 300
 301 (defpsmacro when (test &rest body)
 302   `(if ,test (progn ,@body)))
 303
 304 (defpsmacro unless (test &rest body)
 305   `(if (not ,test) (progn ,@body)))
 306
 307 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 308 ;;; function definition
 309
 310 (defvar *vars-bound-in-enclosing-lexical-scopes* ())
 311
 312 (defun add-implicit-return (fbody)
 313   (let ((last-thing (car (last fbody))))
 314     (if (ps-statement? last-thing)
 315         fbody
 316         (append (butlast fbody)
 317                 `((return ,last-thing))))))
 318
 319 (defun compile-function-definition (args body)
 320   (let ((args (mapcar #'ps-compile-symbol args)))
 321     (list args
 322           (let* ((*enclosing-lexical-block-declarations*
 323                   ())
 324                  (*vars-bound-in-enclosing-lexical-scopes*
 325                   (append args *vars-bound-in-enclosing-lexical-scopes*))
 326                  (body
 327                   (ps-compile-statement `(progn ,@(add-implicit-return body))))
 328                  (var-decls
 329                   (ps-compile-statement
 330                    `(progn ,@(mapcar (lambda (var)
 331                                        `(var ,var))
 332                                      *enclosing-lexical-block-declarations*)))))
 333             `(js:block ,@(cdr var-decls) ,@(cdr body))))))
 334
 335 (define-ps-special-form %js-lambda (args &rest body)
 336   `(js:lambda ,@(compile-function-definition args body)))
 337
 338 (define-ps-special-form %js-defun (name args &rest body)
 339   `(js:defun ,name ,@(compile-function-definition args body)))
 340
 341 (defun parse-function-body (body)
 342   (let* ((docstring (when (stringp (first body))
 343                       (first body)))
 344          (body-forms (if docstring (rest body) body)))
 345     (values body-forms docstring)))
 346
 347 (defun parse-key-spec (key-spec)
 348   "parses an &key parameter.  Returns 5 values:
 349 var, init-form,  keyword-name, supplied-p-var, init-form-supplied-p.
 350
 351 Syntax of key spec:
 352 [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}*
 353 "
 354   (let* ((var (cond ((symbolp key-spec) key-spec)
 355                     ((and (listp key-spec) (symbolp (first key-spec))) (first key-spec))
 356                     ((and (listp key-spec) (listp (first key-spec)))   (second (first key-spec)))))
 357          (keyword-name (if (and (listp key-spec) (listp (first key-spec)))
 358                            (first (first key-spec))
 359                            (intern (string var) :keyword)))
 360          (init-form (if (listp key-spec) (second key-spec) nil))
 361          (init-form-supplied-p (if (listp key-spec) t nil))
 362          (supplied-p-var (if (listp key-spec) (third key-spec) nil)))
 363     (values var init-form keyword-name supplied-p-var init-form-supplied-p)))
 364
 365 (defun parse-optional-spec (spec)
 366   "Parses an &optional parameter.  Returns 3 values: var, init-form, supplied-p-var.
 367 [&optional {var | (var [init-form [supplied-p-parameter]])}*] "
 368   (let* ((var (cond ((symbolp spec) spec)
 369                     ((and (listp spec) (first spec)))))
 370          (init-form (if (listp spec) (second spec)))
 371          (supplied-p-var (if (listp spec) (third spec))))
 372     (values var init-form supplied-p-var)))
 373
 374 (defun parse-aux-spec (spec)
 375   "Returns two values: variable and init-form"
 376   ;; [&aux {var | (var [init-form])}*])
 377   (values (if (symbolp spec) spec (first spec))
 378           (when (listp spec) (second spec))))
 379
 380 (defpsmacro defaultf (name value suppl)
 381   `(progn
 382      ,@(when suppl `((var ,suppl t)))
 383      (when (=== ,name undefined)
 384        (setf ,name ,value ,@(when suppl (list suppl nil))))))
 385
 386 (defun parse-extended-function (lambda-list body)
 387   "Returns two values: the effective arguments and body for a function with
 388 the given lambda-list and body."
 389
 390   ;; The lambda list is transformed as follows, since a javascript
 391   ;; lambda list is just a list of variable names, and you have access
 392   ;; to the arguments variable inside the function:
 393
 394   ;; * standard variables are the mapped directly into the js-lambda
 395   ;;   list
 396
 397   ;; * optional variables' variable names are mapped directly into the
 398   ;;   lambda list, and for each optional variable with name v,
 399   ;;   default value d, and supplied-p parameter s, a form is produced
 400   ;;   (defaultf v d s)
 401
 402   ;; * keyword variables are not included in the js-lambda list, but
 403   ;;   instead are obtained from the magic js ARGUMENTS
 404   ;;   pseudo-array. Code assigning values to keyword vars is
 405   ;;   prepended to the body of the function. Defaults and supplied-p
 406   ;;   are handled using the same mechanism as with optional vars.
 407   (multiple-value-bind (requireds optionals rest? rest keys? keys allow? aux?
 408                                   aux more? more-context more-count key-object)
 409       (parse-lambda-list lambda-list)
 410     (declare (ignore allow? aux? aux more? more-context more-count key-object))
 411     (let* ( ;; optionals are of form (var default-value)
 412            (effective-args
 413             (remove-if #'null
 414                        (append requireds
 415                                (mapcar #'parse-optional-spec optionals))))
 416            (opt-forms
 417             (mapcar (lambda (opt-spec)
 418                       (multiple-value-bind (var val suppl)
 419                           (parse-optional-spec opt-spec)
 420                         `(defaultf ,var ,val ,suppl)))
 421                     optionals))
 422            (key-forms
 423             (when keys?
 424               (if (< *js-target-version* 1.6)
 425                   (with-ps-gensyms (n)
 426                     (let ((decls nil)
 427                           (assigns nil)
 428                           (defaults nil))
 429                       (mapc
 430                        (lambda (k)
 431                          (multiple-value-bind (var init-form
 432                                                    keyword-str suppl)
 433                              (parse-key-spec k)
 434                            (push `(var ,var)
 435                                  decls)
 436                            (push `(,keyword-str (setf ,var (aref arguments (1+ ,n))))
 437                                  assigns)
 438                            (push (list 'defaultf var init-form suppl)
 439                                  defaults)))
 440                        (reverse keys))
 441                       `(,@decls
 442                         (loop for ,n from ,(length requireds)
 443                            below (length arguments) by 2 do
 444                            (case (aref arguments ,n) ,@assigns))
 445                         ,@defaults)))
 446                   (mapcar
 447                    (lambda (k)
 448                      (multiple-value-bind (var init-form keyword-str)
 449                          (parse-key-spec k)
 450                        (with-ps-gensyms (x)
 451                          `(let ((,x ((@ *Array prototype index-of call)
 452                                      arguments ,keyword-str
 453                                      ,(length requireds))))
 454                             (var ,var (if (= -1 ,x)
 455                                           ,init-form
 456                                           (aref arguments (1+ ,x))))))))
 457                    keys))))
 458            (rest-form
 459             (when rest?
 460               (with-ps-gensyms (i)
 461                 `(progn (var ,rest (array))
 462                         (dotimes (,i (- (get-property arguments 'length)
 463                                         ,(length effective-args)))
 464                           (setf (aref ,rest
 465                                       ,i)
 466                                 (aref arguments
 467                                       (+ ,i ,(length effective-args)))))))))
 468            (body-paren-forms (parse-function-body body))
 469            (effective-body (append opt-forms
 470                                    key-forms
 471                                    (awhen rest-form (list it))
 472                                    body-paren-forms)))
 473       (values effective-args effective-body))))
 474
 475 (defpsmacro defun (name lambda-list &body body)
 476   "An extended defun macro that allows cool things like keyword arguments.
 477 lambda-list::=
 478  (var*
 479   [&optional {var | (var [init-form [supplied-p-parameter]])}*]
 480   [&rest var]
 481   [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
 482   [&aux {var | (var [init-form])}*])"
 483   (if (symbolp name)
 484       `(defun-function ,name ,lambda-list ,@body)
 485       (progn (assert (and (listp name) (= (length name) 2) (eq 'setf (car name))) ()
 486                      "(defun ~s ~s ...) needs to have a symbol or (setf symbol) for a name." name lambda-list)
 487              `(defun-setf ,name ,lambda-list ,@body))))
 488
 489 (defpsmacro defun-function (name lambda-list &body body)
 490   (multiple-value-bind (effective-args effective-body)
 491       (parse-extended-function lambda-list body)
 492     `(%js-defun ,name ,effective-args
 493                 ,@effective-body)))
 494
 495 (defpsmacro lambda (lambda-list &body body)
 496   "An extended defun macro that allows cool things like keyword arguments.
 497 lambda-list::=
 498  (var*
 499   [&optional {var | (var [init-form [supplied-p-parameter]])}*]
 500   [&rest var]
 501   [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
 502   [&aux {var | (var [init-form])}*])"
 503   (multiple-value-bind (effective-args effective-body)
 504       (parse-extended-function lambda-list body)
 505     `(%js-lambda ,effective-args
 506                  ,@effective-body)))
 507
 508 (define-ps-special-form flet (fn-defs &rest body)
 509   (let ((fn-renames (make-macro-dictionary)))
 510     (loop for (fn-name) in fn-defs do
 511          (setf (gethash fn-name fn-renames) (ps-gensym fn-name)))
 512     (let ((fn-defs (loop for (fn-name . def) in fn-defs collect
 513                         (ps-compile `(var ,(gethash fn-name fn-renames)
 514                                           (lambda ,@def)))))
 515           (*ps-local-function-names*
 516            (cons fn-renames *ps-local-function-names*)))
 517       `(,(if compile-expression? 'js:|,| 'js:block)
 518          ,@fn-defs ,@(flatten-blocks (mapcar #'ps-compile body))))))
 519
 520 (define-ps-special-form labels (fn-defs &rest body)
 521   (with-local-macro-environment (local-fn-renames *ps-local-function-names*)
 522     (loop for (fn-name) in fn-defs do
 523          (setf (gethash fn-name local-fn-renames) (ps-gensym fn-name)))
 524     (ps-compile
 525      `(progn ,@(loop for (fn-name . def) in fn-defs collect
 526                     `(var ,(gethash fn-name local-fn-renames) (lambda ,@def)))
 527              ,@body))))
 528
 529 (define-ps-special-form function (fn-name)
 530   (ps-compile (maybe-rename-local-function fn-name)))
 531
 532 (defvar *defun-setf-name-prefix* "__setf_")
 533
 534 (defpsmacro defun-setf (setf-name lambda-list &body body)
 535   (let ((mangled-function-name (intern (concatenate 'string *defun-setf-name-prefix* (symbol-name (second setf-name)))
 536                                        (symbol-package (second setf-name))))
 537         (function-args (cdr (ordered-set-difference lambda-list lambda-list-keywords))))
 538     (ps* `(defsetf ,(second setf-name) ,(cdr lambda-list) (store-var)
 539             `(,',mangled-function-name ,store-var ,@(list ,@function-args))))
 540     `(defun ,mangled-function-name ,lambda-list ,@body)))
 541
 542 (defpsmacro defsetf-long (access-fn lambda-list (store-var) form)
 543   (setf (gethash access-fn *ps-setf-expanders*)
 544         (compile nil
 545                  (let ((var-bindings (ordered-set-difference lambda-list lambda-list-keywords)))
 546                    `(lambda (access-fn-args store-form)
 547                       (destructuring-bind ,lambda-list
 548                           access-fn-args
 549                         (let* ((,store-var (ps-gensym))
 550                                (gensymed-names (loop repeat ,(length var-bindings) collecting (ps-gensym)))
 551                                (gensymed-arg-bindings (mapcar #'list gensymed-names (list ,@var-bindings))))
 552                           (destructuring-bind ,var-bindings
 553                               gensymed-names
 554                             `(let* (,@gensymed-arg-bindings
 555                                     (,,store-var ,store-form))
 556                                ,,form))))))))
 557   nil)
 558
 559 (defpsmacro defsetf-short (access-fn update-fn &optional docstring)
 560   (declare (ignore docstring))
 561   (setf (gethash access-fn *ps-setf-expanders*)
 562         (lambda (access-fn-args store-form)
 563           `(,update-fn ,@access-fn-args ,store-form)))
 564   nil)
 565
 566 (defpsmacro defsetf (access-fn &rest args)
 567   `(,(if (= (length args) 3) 'defsetf-long 'defsetf-short) ,access-fn ,@args))
 568
 569 (defpsmacro funcall (&rest arg-form)
 570   arg-form)
 571
 572 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 573 ;;; macros
 574 (define-ps-special-form macrolet (macros &body body)
 575   (with-local-macro-environment (local-macro-dict *ps-macro-env*)
 576     (dolist (macro macros)
 577       (destructuring-bind (name arglist &body body)
 578           macro
 579         (setf (gethash name local-macro-dict) (eval (make-ps-macro-function arglist body)))))
 580     (ps-compile `(progn ,@body))))
 581
 582 (define-ps-special-form symbol-macrolet (symbol-macros &body body)
 583   (with-local-macro-environment (local-macro-dict *ps-symbol-macro-env*)
 584     (let (local-var-bindings)
 585       (dolist (macro symbol-macros)
 586         (destructuring-bind (name expansion)
 587             macro
 588           (setf (gethash name local-macro-dict) (lambda (x)
 589                                                   (declare (ignore x))
 590                                                   expansion))
 591           (push name local-var-bindings)))
 592       (let ((*vars-bound-in-enclosing-lexical-scopes*
 593              (append local-var-bindings
 594                      *vars-bound-in-enclosing-lexical-scopes*)))
 595         (ps-compile `(progn ,@body))))))
 596
 597 (define-ps-special-form defmacro (name args &body body) ;; should this be a macro?
 598   (eval `(defpsmacro ,name ,args ,@body))
 599   nil)
 600
 601 (define-ps-special-form define-symbol-macro (name expansion) ;; should this be a macro?
 602   (eval `(define-ps-symbol-macro ,name ,expansion))
 603   nil)
 604
 605 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 606 ;;; objects
 607 (add-ps-reserved-symbol '{})
 608 (define-ps-symbol-macro {} (create))
 609
 610 (define-ps-special-form create (&rest arrows)
 611   `(js:object
 612     ,@(loop for (key val-expr) on arrows by #'cddr collecting
 613            (progn
 614              (assert (or (stringp key) (numberp key) (symbolp key))
 615                      ()
 616                      "Slot key ~s is not one of symbol, string or number."
 617                      key)
 618              (cons (aif (ps-reserved-symbol-p key) it key)
 619                    (ps-compile-expression (ps-macroexpand val-expr)))))))
 620
 621 (define-ps-special-form instanceof (value type)
 622   `(js:instanceof ,(ps-compile-expression value)
 623                   ,(ps-compile-expression type)))
 624
 625 (define-ps-special-form %js-get-property (obj slot)
 626   (let ((slot (ps-macroexpand slot)))
 627     `(js:get-property ,(ps-compile-expression (ps-macroexpand obj))
 628                       ,(let ((slot (if (and (listp slot) (eq 'quote (car slot)))
 629                                        (second slot) ;; assume we're quoting a symbol
 630                                        (ps-compile-expression slot))))
 631                             (if (and (symbolp slot)
 632                                      (ps-reserved-symbol-p slot))
 633                                 (symbol-name-to-js-string slot)
 634                                 slot)))))
 635
 636 (defpsmacro get-property (obj &rest slots)
 637   (if (null (rest slots))
 638       `(%js-get-property ,obj ,(first slots))
 639       `(get-property (get-property ,obj ,(first slots)) ,@(rest slots))))
 640
 641 (defpsmacro with-slots (slots object &rest body)
 642   (flet ((slot-var (slot) (if (listp slot) (first slot) slot))
 643          (slot-symbol (slot) (if (listp slot) (second slot) slot)))
 644     `(symbol-macrolet ,(mapcar #'(lambda (slot)
 645                                    `(,(slot-var slot) (get-property ,object ',(slot-symbol slot))))
 646                                slots)
 647        ,@body)))
 648
 649 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 650 ;;; assignment and binding
 651 (defun assignment-op (op)
 652   (case op
 653     (+ '+=)
 654     (~ '~=)
 655     (\& '\&=)
 656     (\| '\|=)
 657     (- '-=)
 658     (* '*=)
 659     (% '%=)
 660     (>> '>>=)
 661     (^  '^=)
 662     (<< '<<=)
 663     (>>> '>>>=)
 664     (/   '/=)
 665     (t   nil)))
 666
 667 (define-ps-special-form setf1% (lhs rhs)
 668   (let ((lhs (ps-compile-expression (ps-macroexpand lhs)))
 669         (rhs (ps-compile-expression (ps-macroexpand rhs))))
 670     (if (and (listp rhs)
 671              (eq 'js:operator (car rhs))
 672              (member (cadr rhs) '(+ *))
 673              (equalp lhs (caddr rhs)))
 674         `(js:operator ,(assignment-op (cadr rhs)) ,lhs (js:operator ,(cadr rhs) ,@(cdddr rhs)))
 675         `(js:= ,lhs ,rhs))))
 676
 677 (defpsmacro setf (&rest args)
 678   (assert (evenp (length args)) ()
 679           "~s does not have an even number of arguments." `(setf ,args))
 680   `(progn ,@(loop for (place value) on args by #'cddr collect
 681                  (let ((place (ps-macroexpand place)))
 682                    (aif (and (listp place) (gethash (car place) *ps-setf-expanders*))
 683                         (funcall it (cdr place) value)
 684                         `(setf1% ,place ,value))))))
 685
 686 (defpsmacro psetf (&rest args)
 687   (let ((places (loop for x in args by #'cddr collect x))
 688         (vals (loop for x in (cdr args) by #'cddr collect x)))
 689     (let ((gensyms (mapcar (lambda (x) (declare (ignore x)) (ps-gensym)) places)))
 690       `(let ,(mapcar #'list gensyms vals)
 691          (setf ,@(mapcan #'list places gensyms))))))
 692
 693 (defun check-setq-args (args)
 694   (let ((vars (loop for x in args by #'cddr collect x)))
 695     (let ((non-var (find-if (complement #'symbolp) vars)))
 696       (when non-var
 697         (error 'type-error :datum non-var :expected-type 'symbol)))))
 698
 699 (defpsmacro setq (&rest args)
 700   (check-setq-args args)
 701   `(setf ,@args))
 702
 703 (defpsmacro psetq (&rest args)
 704   (check-setq-args args)
 705   `(psetf ,@args))
 706
 707 (define-ps-special-form var (name &optional (value (values) value-provided?) documentation)
 708   (declare (ignore documentation))
 709   (let ((name (ps-macroexpand name)))
 710     (if compile-expression?
 711         (progn (push name *enclosing-lexical-block-declarations*)
 712                (when value-provided?
 713                  (ps-compile-expression `(setf ,name ,value))))
 714         `(js:var ,name ,@(when value-provided?
 715                                (list (ps-compile-expression (ps-macroexpand value))))))))
 716
 717 (defpsmacro defvar (name &optional (value (values) value-provided?) documentation)
 718   ;; this must be used as a top-level form, otherwise the resulting behavior will be undefined.
 719   (declare (ignore documentation))
 720   (pushnew name *ps-special-variables*)
 721   `(var ,name ,@(when value-provided? (list value))))
 722
 723 (define-ps-special-form let (bindings &body body)
 724   (let* (lexical-bindings-introduced-here
 725          (normalized-bindings (mapcar (lambda (x)
 726                                         (if (symbolp x)
 727                                             (list x nil)
 728                                             (list (car x) (ps-macroexpand (cadr x)))))
 729                                       bindings))
 730          (free-variables-in-binding-value-expressions (mapcan (lambda (x) (flatten (cadr x)))
 731                                                               normalized-bindings)))
 732     (flet ((maybe-rename-lexical-var (x)
 733              (if (or (member x *vars-bound-in-enclosing-lexical-scopes*)
 734                      (member x free-variables-in-binding-value-expressions))
 735                  (ps-gensym x)
 736                  (progn (push x lexical-bindings-introduced-here) nil)))
 737            (rename (x) (first x))
 738            (var (x) (second x))
 739            (val (x) (third x)))
 740       (let* ((lexical-bindings (loop for x in normalized-bindings
 741                                   unless (ps-special-variable-p (car x))
 742                                   collect (cons (maybe-rename-lexical-var (car x)) x)))
 743              (dynamic-bindings (loop for x in normalized-bindings
 744                                   when (ps-special-variable-p (car x))
 745                                   collect (cons (ps-gensym (format nil "~A_~A" (car x) 'tmp-stack)) x)))
 746              (renamed-body `(symbol-macrolet ,(loop for x in lexical-bindings
 747                                                  when (rename x) collect
 748                                                  `(,(var x) ,(rename x)))
 749                               ,@body))
 750              (*vars-bound-in-enclosing-lexical-scopes* (append lexical-bindings-introduced-here
 751                                                                *vars-bound-in-enclosing-lexical-scopes*)))
 752         (ps-compile
 753          `(progn
 754             ,@(mapcar (lambda (x) `(var ,(or (rename x) (var x)) ,(val x))) lexical-bindings)
 755             ,(if dynamic-bindings
 756                  `(progn ,@(mapcar (lambda (x) `(var ,(rename x))) dynamic-bindings)
 757                          (try (progn (setf ,@(loop for x in dynamic-bindings append
 758                                                   `(,(rename x) ,(var x)
 759                                                      ,(var x) ,(val x))))
 760                                      ,renamed-body)
 761                               (:finally
 762                                (setf ,@(mapcan (lambda (x) `(,(var x) ,(rename x))) dynamic-bindings)))))
 763                  renamed-body)))))))
 764
 765 (defpsmacro let* (bindings &body body)
 766   (if bindings
 767       `(let (,(car bindings))
 768          (let* ,(cdr bindings)
 769            ,@body))
 770       `(progn ,@body)))
 771
 772 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 773 ;;; iteration
 774 (defun make-for-vars/inits (init-forms)
 775   (mapcar (lambda (x)
 776             (cons (ps-compile-symbol (ps-macroexpand (if (atom x) x (first x))))
 777                   (ps-compile-expression (ps-macroexpand (if (atom x) nil (second x))))))
 778           init-forms))
 779
 780 (define-ps-special-form labeled-for (label init-forms cond-forms step-forms &rest body)
 781   `(js:for ,label
 782            ,(make-for-vars/inits init-forms)
 783            ,(mapcar (lambda (x) (ps-compile-expression (ps-macroexpand x))) cond-forms)
 784            ,(mapcar (lambda (x) (ps-compile-expression (ps-macroexpand x))) step-forms)
 785            ,(ps-compile-statement `(progn ,@body))))
 786
 787 (defpsmacro for (init-forms cond-forms step-forms &body body)
 788   `(labeled-for nil ,init-forms ,cond-forms ,step-forms ,@body))
 789
 790 (defun do-make-let-bindings (decls)
 791   (mapcar (lambda (x)
 792             (if (atom x) x
 793                 (if (endp (cdr x)) (list (car x))
 794                     (subseq x 0 2))))
 795           decls))
 796
 797 (defun do-make-init-vars (decls)
 798   (mapcar (lambda (x) (if (atom x) x (first x))) decls))
 799
 800 (defun do-make-init-vals (decls)
 801   (mapcar (lambda (x) (if (or (atom x) (endp (cdr x))) nil (second x))) decls))
 802
 803 (defun do-make-for-vars/init (decls)
 804   (mapcar (lambda (x)
 805             (if (atom x) x
 806                 (if (endp (cdr x)) x
 807                     (subseq x 0 2))))
 808           decls))
 809
 810 (defun do-make-for-steps (decls)
 811   (mapcar (lambda (x)
 812             `(setf ,(first x) ,(third x)))
 813           (remove-if (lambda (x) (or (atom x) (< (length x) 3))) decls)))
 814
 815 (defun do-make-iter-psteps (decls)
 816   `(psetq
 817     ,@(mapcan (lambda (x) (list (first x) (third x)))
 818               (remove-if (lambda (x) (or (atom x) (< (length x) 3))) decls))))
 819
 820 (defpsmacro do* (decls (termination &optional (result nil result?)) &body body)
 821   (if result?
 822       `((lambda ()
 823           (for ,(do-make-for-vars/init decls) ((not ,termination)) ,(do-make-for-steps decls)
 824                ,@body)
 825           (return ,result)))
 826       `(for ,(do-make-for-vars/init decls) ((not ,termination)) ,(do-make-for-steps decls)
 827             ,@body)))
 828
 829 (defpsmacro do (decls (termination &optional (result nil result?)) &body body)
 830   (if result?
 831       `((lambda ,(do-make-init-vars decls)
 832           (for () ((not ,termination)) ()
 833                ,@body
 834                ,(do-make-iter-psteps decls))
 835           (return ,result))
 836         ,@(do-make-init-vals decls))
 837       `(let ,(do-make-let-bindings decls)
 838          (for () ((not ,termination)) ()
 839               ,@body
 840               ,(do-make-iter-psteps decls)))))
 841
 842 (define-ps-special-form for-in ((var object) &rest body)
 843   `(js:for-in ,(ps-compile-expression var)
 844               ,(ps-compile-expression (ps-macroexpand object))
 845               ,(ps-compile-statement `(progn ,@body))))
 846
 847 (define-ps-special-form while (test &rest body)
 848   `(js:while ,(ps-compile-expression test)
 849      ,(ps-compile-statement `(progn ,@body))))
 850
 851 (defpsmacro dotimes ((var count &optional (result nil result?)) &rest body)
 852   `(do* ((,var 0 (1+ ,var)))
 853         ((>= ,var ,count) ,@(when result? (list result)))
 854      ,@body))
 855
 856 (defpsmacro dolist ((var array &optional (result nil result?)) &body body)
 857   (let* ((idx (ps-gensym "_js_idx"))
 858          (introduce-array-var? (not (symbolp array)))
 859          (arrvar (if introduce-array-var?
 860                      (ps-gensym "_js_arrvar")
 861                      array)))
 862     `(do* (,var
 863            ,@(when introduce-array-var?
 864                    (list (list arrvar array)))
 865            (,idx 0 (1+ ,idx)))
 866           ((>= ,idx (get-property ,arrvar 'length))
 867            ,@(when result? (list result)))
 868        (setq ,var (aref ,arrvar ,idx))
 869        ,@body)))
 870
 871 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 872 ;;; misc
 873 (define-ps-special-form with (expression &rest body)
 874   `(js:with ,(ps-compile-expression expression)
 875      ,(ps-compile-statement `(progn ,@body))))
 876
 877 (define-ps-special-form try (form &rest clauses)
 878   (let ((catch (cdr (assoc :catch clauses)))
 879         (finally (cdr (assoc :finally clauses))))
 880     (assert (not (cdar catch)) nil "Sorry, currently only simple catch forms are supported.")
 881     (assert (or catch finally) ()
 882             "Try form should have either a catch or a finally clause or both.")
 883     `(js:try ,(ps-compile-statement `(progn ,form))
 884              :catch ,(when catch (list (ps-compile-symbol (caar catch))
 885                                        (ps-compile-statement `(progn ,@(cdr catch)))))
 886              :finally ,(when finally (ps-compile-statement `(progn ,@finally))))))
 887
 888 (define-ps-special-form cc-if (test &rest body)
 889   `(js:cc-if ,test ,@(mapcar #'ps-compile-statement body)))
 890
 891 (define-ps-special-form regex (regex)
 892   `(js:regex ,(string regex)))
 893
 894 (define-ps-special-form lisp (lisp-form)
 895   ;; (ps (foo (lisp bar))) is in effect equivalent to (ps* `(foo ,bar))
 896   ;; when called from inside of ps*, lisp-form has access only to the dynamic environment (like for eval)
 897   `(js:escape (compiled-form-to-string (let ((compile-expression? ,compile-expression?))
 898                                          (ps-compile ,lisp-form)))))
 899
 900 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 901 ;;; eval-when
 902 (define-ps-special-form eval-when (situation-list &body body)
 903   "(eval-when (situation*) body-form*)
 904
 905 The body forms are evaluated only during the given SITUATION. The accepted SITUATIONS are
 906 :load-toplevel, :compile-toplevel, and :execute.  The code in BODY-FORM is assumed to be
 907 COMMON-LISP code in :compile-toplevel and :load-toplevel sitations, and parenscript code in
 908 :execute.  "
 909   (when (and (member :compile-toplevel situation-list)
 910              (member *ps-compilation-level* '(:toplevel :inside-toplevel-form)))
 911     (eval `(progn ,@body)))
 912   (if (member :execute situation-list)
 913       (ps-compile `(progn ,@body))
 914       (ps-compile `(progn))))