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