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