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