src/special-forms.lisp

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