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