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