src/special-forms.lisp

   1 (in-package :parenscript)
   2
   3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   4 ;;; literals
   5 (defmacro defpsliteral (name string)
   6   `(progn (pushnew ',name *ps-literals*)
   7     (define-ps-special-form ,name (expecting)
   8       (declare (ignore expecting))
   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                 (pushnew ',name *ps-literals*)
  22                 (define-ps-special-form ,name (expecting &optional label)
  23                   (declare (ignore expecting))
  24                   (list ',printer label)))))
  25   (def-for-literal break js-break)
  26   (def-for-literal continue js-continue))
  27
  28 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29 ;;; unary operators
  30 (mapcar (lambda (op) (eval `(define-ps-special-form ,op (expecting value)
  31                              (declare (ignore expecting))
  32                              (list 'js-named-operator ',op (compile-parenscript-form value)))))
  33         '(throw delete void typeof new))
  34
  35 (define-ps-special-form return (expecting &optional value)
  36   (declare (ignore expecting))
  37   (list 'js-return (compile-parenscript-form value :expecting :expression)))
  38
  39 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  40 ;;; arrays
  41 (define-ps-special-form array (expecting &rest values)
  42   (declare (ignore expecting))
  43   (cons 'array-literal (mapcar (lambda (form) (compile-parenscript-form form :expecting :expression))
  44                                values)))
  45
  46 (define-ps-special-form aref (expecting array &rest coords)
  47   (declare (ignore expecting))
  48   (list 'js-aref (compile-parenscript-form array :expecting :expression)
  49         (mapcar (lambda (form)
  50                   (compile-parenscript-form form :expecting :expression))
  51                 coords)))
  52
  53 (define-ps-special-form {} (expecting &rest arrows)
  54   (declare (ignore expecting))
  55   (cons 'object-literal (loop for (key value) on arrows by #'cddr
  56                               collect (cons key (compile-parenscript-form value :expecting :expression)))))
  57
  58 (defpsmacro list (&rest values)
  59   `(array ,@values))
  60
  61 (defpsmacro make-array (&rest inits)
  62   `(new (*array ,@inits)))
  63
  64 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  65 ;;; operators
  66 (define-ps-special-form incf (expecting x &optional (delta 1))
  67   (declare (ignore expecting))
  68   (if (equal delta 1)
  69       (list 'unary-operator "++" (compile-parenscript-form x :expecting :expression) :prefix t)
  70       (list 'operator '+= (list (compile-parenscript-form x :expecting :expression)
  71                                 (compile-parenscript-form delta :expecting :expression)))))
  72
  73 (define-ps-special-form decf (expecting x &optional (delta 1))
  74   (declare (ignore expecting))
  75   (if (equal delta 1)
  76       (list 'unary-operator "--" (compile-parenscript-form x :expecting :expression) :prefix t)
  77       (list 'operator '-= (list (compile-parenscript-form x :expecting :expression)
  78                                 (compile-parenscript-form delta :expecting :expression)))))
  79
  80 (define-ps-special-form - (expecting first &rest rest)
  81   (declare (ignore expecting))
  82   (if (null rest)
  83       (list 'unary-operator "-" (compile-parenscript-form first :expecting :expression) :prefix t)
  84       (list 'operator '- (mapcar (lambda (val) (compile-parenscript-form val :expecting :expression))
  85                                  (cons first rest)))))
  86
  87 (define-ps-special-form not (expecting x)
  88   (declare (ignore expecting))
  89   (let ((form (compile-parenscript-form x :expecting :expression))
  90         (not-op nil))
  91     (if (and (eql (first form) 'operator)
  92              (= (length (third form)) 2)
  93              (setf not-op (case (second form)
  94                             (== '!=)
  95                             (< '>=)
  96                             (> '<=)
  97                             (<= '>)
  98                             (>= '<)
  99                             (!= '==)
 100                             (=== '!==)
 101                             (!== '===)
 102                             (t nil))))
 103         (list 'operator not-op (third form))
 104         (list 'unary-operator "!" form :prefix t))))
 105
 106 (define-ps-special-form ~ (expecting x)
 107   (declare (ignore expecting))
 108   (list 'unary-operator "~" (compile-parenscript-form x :expecting :expression) :prefix t))
 109
 110 (defpsmacro 1- (form)
 111   `(- ,form 1))
 112
 113 (defpsmacro 1+ (form)
 114   `(+ ,form 1))
 115
 116 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 117 ;;; control structures
 118 (defun flatten-blocks (body)
 119   (when body
 120     (if (and (listp (car body))
 121              (eql 'js-block (caar body)))
 122         (append (third (car body)) (flatten-blocks (cdr body)))
 123         (cons (car body) (flatten-blocks (cdr body))))))
 124
 125 (defun constant-literal-form-p (form)
 126   (or (numberp form)
 127       (stringp form)
 128       (and (listp form)
 129            (eql 'js-literal (car form)))))
 130
 131 (define-ps-special-form progn (expecting &rest body)
 132   (if (and (eql expecting :expression) (= 1 (length body)))
 133       (compile-parenscript-form (car body) :expecting :expression)
 134       (list 'js-block
 135             expecting
 136             (let* ((block (mapcar (lambda (form)
 137                                     (compile-parenscript-form form :expecting expecting))
 138                                   body))
 139                    (clean-block (remove nil block))
 140                    (flat-block (flatten-blocks clean-block))
 141                    (reachable-block (append (remove-if #'constant-literal-form-p (butlast flat-block))
 142                                             (last flat-block))))
 143               reachable-block))))
 144
 145 (define-ps-special-form cond (expecting &rest clauses)
 146   (ecase expecting
 147     (:statement (list 'js-cond-statement
 148                       (mapcar (lambda (clause)
 149                                 (destructuring-bind (test &rest body)
 150                                     clause
 151                                   (list (compile-parenscript-form test :expecting :expression)
 152                                         (compile-parenscript-form `(progn ,@body) :expecting :statement))))
 153                               clauses)))
 154     (:expression (make-cond-clauses-into-nested-ifs clauses))))
 155
 156 (defun make-cond-clauses-into-nested-ifs (clauses)
 157   (if clauses
 158       (destructuring-bind (test &rest body)
 159           (car clauses)
 160         (if (eq t test)
 161             (compile-parenscript-form `(progn ,@body) :expecting :expression)
 162             (list 'js-expression-if (compile-parenscript-form test :expecting :expression)
 163                   (compile-parenscript-form `(progn ,@body) :expecting :expression)
 164                   (make-cond-clauses-into-nested-ifs (cdr clauses)))))
 165       (compile-parenscript-form nil :expecting :expression)))
 166
 167 (define-ps-special-form if (expecting test then &optional else)
 168   (ecase expecting
 169     (:statement (list 'js-statement-if (compile-parenscript-form test :expecting :expression)
 170                       (compile-parenscript-form `(progn ,then))
 171                       (when else (compile-parenscript-form `(progn ,else)))))
 172     (:expression (list 'js-expression-if (compile-parenscript-form test :expecting :expression)
 173                        (compile-parenscript-form then :expecting :expression)
 174                        (compile-parenscript-form else :expecting :expression)))))
 175
 176 (define-ps-special-form switch (expecting test-expr &rest clauses)
 177   (declare (ignore expecting))
 178   (let ((clauses (mapcar (lambda (clause)
 179                              (let ((val (car clause))
 180                                    (body (cdr clause)))
 181                                (cons (if (eql val 'default)
 182                                          'default
 183                                          (compile-parenscript-form val :expecting :expression))
 184                                      (mapcar (lambda (statement) (compile-parenscript-form statement :expecting :statement))
 185                                              body))))
 186                          clauses))
 187         (expr (compile-parenscript-form test-expr :expecting :expression)))
 188     (list 'js-switch expr clauses)))
 189
 190 (defpsmacro case (value &rest clauses)
 191   (labels ((make-clause (val body more)
 192              (cond ((listp val)
 193                     (append (mapcar #'list (butlast val))
 194                             (make-clause (first (last val)) body more)))
 195                    ((member val '(t otherwise))
 196                     (make-clause 'default body more))
 197                    (more `((,val ,@body break)))
 198                    (t `((,val ,@body))))))
 199     `(switch ,value ,@(mapcon (lambda (clause)
 200                                 (make-clause (car (first clause))
 201                                              (cdr (first clause))
 202                                              (rest clause)))
 203                               clauses))))
 204
 205 (defpsmacro when (test &rest body)
 206   `(if ,test (progn ,@body)))
 207
 208 (defpsmacro unless (test &rest body)
 209   `(if (not ,test) (progn ,@body)))
 210
 211 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 212 ;;; function definition
 213 (defun compile-function-definition (args body)
 214   (list (mapcar (lambda (arg) (compile-parenscript-form arg :expecting :symbol)) args)
 215         (let ((*enclosing-lexical-block-declarations* ()))
 216           ;; the first compilation will produce a list of variables we need to declare in the function body
 217           (compile-parenscript-form `(progn ,@body) :expecting :statement)
 218           ;; now declare and compile
 219           (compile-parenscript-form `(progn ,@(loop for var in *enclosing-lexical-block-declarations* collect `(var ,var))
 220                                       ,@body) :expecting :statement))))
 221
 222 (define-ps-special-form %js-lambda (expecting args &rest body)
 223   (declare (ignore expecting))
 224   (cons 'js-lambda (compile-function-definition args body)))
 225
 226 (define-ps-special-form %js-defun (expecting name args &rest body)
 227   (declare (ignore expecting))
 228   (append (list '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 4 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 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 (place value)
 271   `(setf ,place (or (and (=== undefined ,place) ,value)
 272                  ,place)))
 273
 274 (defun parse-extended-function (lambda-list body &optional name)
 275   "Returns two values: the effective arguments and body for a function with
 276 the given lambda-list and body."
 277
 278   ;; The lambda list is transformed as follows, since a javascript lambda list is just a
 279   ;; list of variable names, and you have access to the arguments variable inside the function:
 280   ;; * standard variables are the mapped directly into the js-lambda list
 281   ;; * optional variables' variable names are mapped directly into the lambda list,
 282   ;;   and for each optional variable with name v and default value d, a form is produced
 283   ;;   (defaultf v d)
 284   ;; * when any keyword variables are in the lambda list, a single 'optional-args' variable is
 285   ;;   appended to the js-lambda list as the last argument.  WITH-SLOTS is used for all
 286   ;;   the variables with  inside the body of the function,
 287   ;;   a (with-slots ((var-name key-name)) optional-args ...)
 288   (declare (ignore name))
 289   (multiple-value-bind (requireds optionals rest? rest keys? keys allow? aux? aux
 290                                   more? more-context more-count key-object)
 291       (parse-lambda-list lambda-list)
 292     (declare (ignore allow? aux? aux more? more-context more-count))
 293     (let* ((options-var (or key-object (ps-gensym)))
 294            ;; optionals are of form (var default-value)
 295            (effective-args
 296             (remove-if
 297              #'null
 298              (append requireds
 299                      (mapcar #'parse-optional-spec optionals)
 300                      (when keys (list options-var)))))
 301            ;; an alist of arg -> default val
 302            (initform-pairs
 303             (remove
 304              nil
 305              (append
 306               ;; optional arguments first
 307               (mapcar #'(lambda (opt-spec)
 308                           (multiple-value-bind (var val) (parse-optional-spec opt-spec)
 309                             (cons var val)))
 310                       optionals)
 311               (if keys? (list (cons options-var '(create))))
 312               (mapcar #'(lambda (key-spec)
 313                           (multiple-value-bind (var val x y specified?) (parse-key-spec key-spec)
 314                             (declare (ignore x y))
 315                             (when specified? (cons var val))))
 316                       keys))))
 317            (body-paren-forms (parse-function-body body)) ;remove documentation
 318            ;;
 319            (initform-forms
 320             (mapcar #'(lambda (default-pair)
 321                         `(defaultf ,(car default-pair) ,(cdr default-pair)))
 322                     initform-pairs))
 323            (rest-form
 324             (if rest?
 325                 (with-ps-gensyms (i)
 326                   `(progn (var ,rest (array))
 327                     (dotimes (,i (- arguments.length ,(length effective-args)))
 328                       (setf (aref ,rest ,i) (aref arguments (+ ,i ,(length effective-args)))))))
 329                 `(progn)))
 330            (effective-body   (append initform-forms (list rest-form) body-paren-forms))
 331            (effective-body
 332             (if keys?
 333                 (list `(with-slots ,(mapcar #'(lambda (key-spec)
 334                                                 (multiple-value-bind (var x key-name)
 335                                                     (parse-key-spec key-spec)
 336                                                   (declare (ignore x))
 337                                                   (list var key-name)))
 338                                             keys)
 339                         ,options-var
 340                         ,@effective-body))
 341                 effective-body)))
 342       (values effective-args effective-body))))
 343
 344 (defpsmacro defun (name lambda-list &body body)
 345   "An extended defun macro that allows cool things like keyword arguments.
 346 lambda-list::=
 347  (var*
 348   [&optional {var | (var [init-form [supplied-p-parameter]])}*]
 349   [&rest var]
 350   [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
 351   [&aux {var | (var [init-form])}*])"
 352   (if (symbolp name)
 353       `(defun-function ,name ,lambda-list ,@body)
 354       (progn (assert (and (= (length name) 2) (eql 'setf (car name))) ()
 355                      "(defun ~s ~s ...) needs to have a symbol or (setf symbol) for a name." name lambda-list)
 356              `(defun-setf ,name ,lambda-list ,@body))))
 357
 358 (defpsmacro defun-function (name lambda-list &body body)
 359   (multiple-value-bind (effective-args effective-body)
 360       (parse-extended-function lambda-list body name)
 361     `(%js-defun ,name ,effective-args
 362       ,@effective-body)))
 363
 364 (defvar *defun-setf-name-prefix* "__setf_")
 365
 366 (defpsmacro defun-setf (setf-name lambda-list &body body)
 367   (let ((mangled-function-name (intern (concatenate 'string *defun-setf-name-prefix* (symbol-name (second setf-name)))
 368                                        (symbol-package (second setf-name))))
 369         (function-args (cdr (ordered-set-difference lambda-list lambda-list-keywords))))
 370     `(progn (defsetf ,(second setf-name) ,(cdr lambda-list) (store-var)
 371               `(,',mangled-function-name ,store-var ,@(list ,@function-args)))
 372             (defun ,mangled-function-name ,lambda-list ,@body))))
 373
 374 (defpsmacro lambda (lambda-list &body body)
 375   "An extended defun macro that allows cool things like keyword arguments.
 376 lambda-list::=
 377  (var*
 378   [&optional {var | (var [init-form [supplied-p-parameter]])}*]
 379   [&rest var]
 380   [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
 381   [&aux {var | (var [init-form])}*])"
 382   (multiple-value-bind (effective-args effective-body)
 383       (parse-extended-function lambda-list body)
 384     `(%js-lambda ,effective-args
 385       ,@effective-body)))
 386
 387 (defpsmacro defsetf-long (access-fn lambda-list (store-var) form)
 388   (setf (get-macro-spec access-fn *script-setf-expanders*)
 389         (compile nil
 390                  (let ((var-bindings (ordered-set-difference lambda-list lambda-list-keywords)))
 391                    `(lambda (access-fn-args store-form)
 392                      (destructuring-bind ,lambda-list
 393                                access-fn-args
 394                        (let* ((,store-var (ps-gensym))
 395                               (gensymed-names (loop repeat ,(length var-bindings) collecting (ps-gensym)))
 396                               (gensymed-arg-bindings (mapcar #'list gensymed-names (list ,@var-bindings))))
 397                          (destructuring-bind ,var-bindings
 398                              gensymed-names
 399                            `(let* (,@gensymed-arg-bindings
 400                                    (,,store-var ,store-form))
 401                              ,,form))))))))
 402   nil)
 403
 404 (defpsmacro defsetf-short (access-fn update-fn &optional docstring)
 405   (declare (ignore docstring))
 406   (setf (get-macro-spec access-fn *script-setf-expanders*)
 407         (lambda (access-fn-args store-form)
 408           `(,update-fn ,@access-fn-args ,store-form)))
 409   nil)
 410
 411 (defpsmacro defsetf (access-fn &rest args)
 412   `(,(if (= (length args) 3) 'defsetf-long 'defsetf-short) ,access-fn ,@args))
 413
 414 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 415 ;;; macros
 416 (defmacro with-temp-macro-environment ((var) &body body)
 417   `(let* ((,var (make-macro-env-dictionary))
 418           (*script-macro-env* (cons ,var *script-macro-env*)))
 419     ,@body))
 420
 421 (define-ps-special-form macrolet (expecting macros &body body)
 422   (declare (ignore expecting))
 423   (with-temp-macro-environment (macro-env-dict)
 424     (dolist (macro macros)
 425       (destructuring-bind (name arglist &body body)
 426           macro
 427         (setf (get-macro-spec name macro-env-dict)
 428               (cons nil (make-ps-macro-function arglist body)))))
 429     (compile-parenscript-form `(progn ,@body))))
 430
 431 (define-ps-special-form symbol-macrolet (expecting symbol-macros &body body)
 432   (declare (ignore expecting))
 433   (with-temp-macro-environment (macro-env-dict)
 434     (dolist (macro symbol-macros)
 435       (destructuring-bind (name expansion)
 436           macro
 437         (setf (get-macro-spec name macro-env-dict)
 438               (cons t (make-ps-macro-function () (list `',expansion))))))
 439     (compile-parenscript-form `(progn ,@body))))
 440
 441 (define-ps-special-form defmacro (expecting name args &body body)
 442   (declare (ignore expecting))
 443   (define-script-macro% name args body :symbol-macro-p nil)
 444   nil)
 445
 446 (define-ps-special-form define-symbol-macro (expecting name expansion)
 447   (declare (ignore expecting))
 448   (define-script-macro% name () (list `',expansion) :symbol-macro-p t)
 449   nil)
 450
 451 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 452 ;;; objects
 453 (define-ps-special-form create (expecting &rest args)
 454   (declare (ignore expecting))
 455   (list 'js-object (loop for (name val) on args by #'cddr collecting
 456                          (let ((name-expr (compile-parenscript-form name :expecting :expression)))
 457                            (assert (or (stringp name-expr)
 458                                        (numberp name-expr)
 459                                        (and (listp name-expr)
 460                                             (or (eql 'js-variable (car name-expr))
 461                                                 (eql 'script-quote (car name-expr)))))
 462                                    ()
 463                                    "Slot ~s is not one of js-variable, keyword, string or number." name-expr)
 464                            (list name-expr (compile-parenscript-form val :expecting :expression))))))
 465
 466 (define-ps-special-form %js-slot-value (expecting obj slot)
 467   (declare (ignore expecting))
 468   (if (ps::ps-macroexpand slot)
 469       (list 'js-slot-value (compile-parenscript-form obj :expecting :expression) (compile-parenscript-form slot))
 470       (compile-parenscript-form obj :expecting :expression)))
 471
 472 (define-ps-special-form instanceof (expecting value type)
 473   (declare (ignore expecting))
 474   (list 'js-instanceof (compile-parenscript-form value :expecting :expression)
 475         (compile-parenscript-form type :expecting :expression)))
 476
 477 (defpsmacro slot-value (obj &rest slots)
 478   (if (null (rest slots))
 479       `(%js-slot-value ,obj ,(first slots))
 480       `(slot-value (slot-value ,obj ,(first slots)) ,@(rest slots))))
 481
 482 (defpsmacro with-slots (slots object &rest body)
 483   (flet ((slot-var (slot) (if (listp slot) (first slot) slot))
 484          (slot-symbol (slot) (if (listp slot) (second slot) slot)))
 485     `(symbol-macrolet ,(mapcar #'(lambda (slot)
 486                                    `(,(slot-var slot) (slot-value ,object ',(slot-symbol slot))))
 487                                slots)
 488       ,@body)))
 489
 490 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 491 ;;; assignment and binding
 492 (defun assignment-op (op)
 493   (case op
 494     (+ '+=)
 495     (~ '~=)
 496     (\& '\&=)
 497     (\| '\|=)
 498     (- '-=)
 499     (* '*=)
 500     (% '%=)
 501     (>> '>>=)
 502     (^  '^=)
 503     (<< '<<=)
 504     (>>> '>>>=)
 505     (/   '/=)
 506     (t   nil)))
 507
 508 (defun smart-setf (lhs rhs)
 509   (if (and (listp rhs)
 510            (eql 'operator (car rhs))
 511            (member lhs (third rhs) :test #'equalp))
 512       (let ((args-without-first (remove lhs (third rhs) :count 1 :end 1 :test #'equalp)))
 513         (cond ((and (assignment-op (second rhs))
 514                     (member (second rhs) '(+ *))
 515                     (equalp lhs (first (third rhs))))
 516                (list 'operator (assignment-op (second rhs))
 517                      (list lhs (list 'operator (second rhs) args-without-first))))
 518               (t (list 'js-assign lhs rhs))))
 519       (list 'js-assign lhs rhs)))
 520
 521 (define-ps-special-form setf1% (expecting lhs rhs)
 522   (declare (ignore expecting))
 523   (smart-setf (compile-parenscript-form lhs :expecting :expression) (compile-parenscript-form rhs :expecting :expression)))
 524
 525 (defpsmacro setf (&rest args)
 526   (flet ((process-setf-clause (place value-form)
 527            (if (and (listp place) (get-macro-spec (car place) *script-setf-expanders*))
 528                (funcall (get-macro-spec (car place) *script-setf-expanders*) (cdr place) value-form)
 529                (let ((exp-place (ps-macroexpand place)))
 530                  (if (and (listp exp-place) (get-macro-spec (car exp-place) *script-setf-expanders*))
 531                      (funcall (get-macro-spec (car exp-place) *script-setf-expanders*) (cdr exp-place) value-form)
 532                      `(setf1% ,exp-place ,value-form))))))
 533     (assert (evenp (length args)) ()
 534             "~s does not have an even number of arguments." (cons 'setf args))
 535     `(progn ,@(loop for (place value) on args by #'cddr collect (process-setf-clause place value)))))
 536
 537 (define-ps-special-form var (expecting name &rest value)
 538   (declare (ignore expecting))
 539   (append (list 'js-var name)
 540           (when value
 541             (assert (= (length value) 1) () "Wrong number of arguments to var: ~s" `(var ,name ,@value))
 542             (list (compile-parenscript-form (car value) :expecting :expression)))))
 543
 544 (defpsmacro defvar (name &rest value)
 545   "Note: this must be used as a top-level form, otherwise the result will be undefined behavior."
 546   (pushnew name *ps-special-variables*)
 547   (assert (or (null value) (= (length value) 1)) () "Wrong number of arguments to defvar: ~s" `(defvar ,name ,@value))
 548   `(var ,name ,@value))
 549
 550 (defpsmacro lexical-let* (bindings &body body)
 551   `((lambda ()
 552       (let* ,bindings
 553         ,@body))))
 554
 555 (defpsmacro let* (bindings &rest body)
 556   (if bindings
 557       (let ((var (if (listp (car bindings)) (caar bindings) (car bindings))))
 558         `(,(if (member var *ps-special-variables*) 'let1-dynamic 'let1) ,(car bindings)
 559           (let* ,(cdr bindings) ,@body)))
 560       `(progn ,@body)))
 561
 562 (defpsmacro let (&rest stuff)
 563   "Right now, let doesn't do parallel assignment."
 564   `(let* ,@stuff))
 565
 566 (define-ps-special-form let1 (expecting binding &rest body)
 567   (ecase expecting
 568     (:statement
 569      (compile-parenscript-form `(progn ,(if (atom binding) `(var ,binding) `(var ,@binding)) ,@body) :expecting :statement))
 570     (:expression
 571      (let ((var (if (atom binding) binding (car binding)))
 572            (variable-assignment (when (listp binding) (cons 'setf binding))))
 573        (push var *enclosing-lexical-block-declarations*)
 574        (compile-parenscript-form `(progn ,variable-assignment ,@body) :expecting :expression)))))
 575
 576 (defpsmacro let1-dynamic ((var value) &rest body)
 577   (with-ps-gensyms (temp-stack-var)
 578     `(progn (var ,temp-stack-var)
 579       (try (progn (setf ,temp-stack-var ,var)
 580                   (setf ,var ,value)
 581                   ,@body)
 582        (:finally (setf ,var ,temp-stack-var))))))
 583
 584 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 585 ;;; iteration
 586 (defun make-for-vars (decls)
 587   (loop for decl in decls
 588         for var = (if (atom decl) decl (first decl))
 589         for init-value = (if (atom decl) nil (second decl))
 590         collect (cons (compile-parenscript-form var :expecting :symbol) (compile-parenscript-form init-value))))
 591
 592 (defun make-for-steps (decls)
 593   (loop for decl in decls
 594         when (= (length decl) 3)
 595         collect (compile-parenscript-form (third decl) :expecting :expression)))
 596
 597 (define-ps-special-form do (expecting decls termination-test &rest body)
 598   (declare (ignore expecting))
 599   (let ((vars (make-for-vars decls))
 600         (steps (make-for-steps decls))
 601         (test (compile-parenscript-form `(not ,(first termination-test)) :expecting :expression))
 602         (body (compile-parenscript-form `(progn ,@body))))
 603     (list 'js-for vars steps test body)))
 604
 605 (define-ps-special-form doeach (expecting decl &rest body)
 606   (declare (ignore expecting))
 607   (list 'js-for-each
 608         (first decl)
 609         (compile-parenscript-form (second decl) :expecting :expression)
 610         (compile-parenscript-form `(progn ,@body))))
 611
 612 (define-ps-special-form while (expecting test &rest body)
 613   (declare (ignore expecting))
 614   (list 'js-while (compile-parenscript-form test :expecting :expression)
 615                   (compile-parenscript-form `(progn ,@body))))
 616
 617 (defpsmacro dotimes (iter &rest body)
 618   (let ((var (first iter))
 619         (times (second iter)))
 620   `(do ((,var 0 (1+ ,var)))
 621        ((>= ,var ,times))
 622      ,@body)))
 623
 624 (defpsmacro dolist (i-array &rest body)
 625   (let ((var (first i-array))
 626         (array (second i-array))
 627         (arrvar (ps-gensym "tmp-arr"))
 628         (idx (ps-gensym "tmp-i")))
 629     `(let* ((,arrvar ,array))
 630       (do ((,idx 0 (1+ ,idx)))
 631           ((>= ,idx (slot-value ,arrvar 'length)))
 632         (let* ((,var (aref ,arrvar ,idx)))
 633           ,@body)))))
 634
 635 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 636 ;;; misc
 637 (define-ps-special-form with (expecting expression &rest body)
 638   (declare (ignore expecting))
 639   (list 'js-with (compile-parenscript-form expression :expecting :expression)
 640                  (compile-parenscript-form `(progn ,@body))))
 641
 642 (define-ps-special-form try (expecting form &rest clauses)
 643   (declare (ignore expecting))
 644   (let ((catch (cdr (assoc :catch clauses)))
 645         (finally (cdr (assoc :finally clauses))))
 646     (assert (not (cdar catch)) nil "Sorry, currently only simple catch forms are supported.")
 647     (assert (or catch finally) ()
 648             "Try form should have either a catch or a finally clause or both.")
 649     (list 'js-try (compile-parenscript-form `(progn ,form))
 650           :catch (when catch (list (compile-parenscript-form (caar catch) :expecting :symbol)
 651                                    (compile-parenscript-form `(progn ,@(cdr catch)))))
 652           :finally (when finally (compile-parenscript-form `(progn ,@finally))))))
 653
 654 (define-ps-special-form cc-if (expecting test &rest body)
 655   (declare (ignore expecting))
 656   (list 'cc-if test (mapcar #'compile-parenscript-form body)))
 657
 658 (define-ps-special-form regex (expecting regex)
 659   (declare (ignore expecting))
 660   (list 'js-regex (string regex)))
 661
 662 (defpsmacro lisp (&body forms)
 663   "Evaluates the given forms in Common Lisp at ParenScript
 664 macro-expansion time. The value of the last form is treated as a
 665 ParenScript expression and is inserted into the generated Javascript
 666 \(use nil for no-op)."
 667   (eval (cons 'progn forms)))