src/js.lisp

   1 (in-package :js)
   2
   3 ;;; ecmascript standard:
   4 ;;; http://www.ecma-international.org/publications/standards/Ecma-262.htm
   5
   6 ;;; javascript name conversion
   7
   8 (defparameter *special-chars*
   9   '((#\! . "Bang")
  10     (#\? . "What")
  11     (#\# . "Hash")
  12     (#\@ . "At")
  13     (#\% . "Percent")
  14     (#\+ . "Plus")
  15     (#\* . "Star")
  16     (#\/ . "Slash")))
  17
  18 (defun string-chars (string)
  19   (coerce string 'list))
  20
  21 (defun constant-string-p (string)
  22   (let ((len (length string))
  23         (constant-chars '(#\+ #\*)))
  24     (and (> len 2)
  25          (member (char string 0) constant-chars)
  26          (member (char string (1- len)) constant-chars))))
  27
  28 (defun first-uppercase-p (string)
  29   (and (> (length string) 1)
  30        (member (char string 0) '(#\+ #\*))))
  31
  32 (defun untouchable-string-p (string)
  33   (and (> (length string) 1)
  34        (char= #\: (char string 0))))
  35
  36 (defun symbol-to-js (symbol)
  37   (when (symbolp symbol)
  38     (setf symbol (symbol-name symbol)))
  39   (let ((symbols (string-split symbol '(#\.))))
  40     (cond ((null symbols) "")
  41           ((= (length symbols) 1)
  42            (let (res
  43                  (do-not-touch nil)
  44                  (lowercase t)
  45                  (all-uppercase nil))
  46              (cond ((constant-string-p symbol)
  47                     (setf all-uppercase t
  48                           symbol (subseq symbol 1 (1- (length symbol)))))
  49                    ((first-uppercase-p symbol)
  50                     (setf lowercase nil
  51                           symbol (subseq symbol 1)))
  52                    ((untouchable-string-p symbol)
  53                     (setf do-not-touch t
  54                           symbol (subseq symbol 1))))
  55              (flet ((reschar (c)
  56                       (push (cond
  57                               (do-not-touch c)
  58                               ((and lowercase (not all-uppercase))
  59                                (char-downcase c))
  60                               (t (char-upcase c)))
  61                             res)
  62                       (setf lowercase t)))
  63                (dotimes (i (length symbol))
  64                  (let ((c (char symbol i)))
  65                    (cond
  66                      ((eql c #\-)
  67                       (setf lowercase (not lowercase)))
  68                      ((assoc c *special-chars*)
  69                       (dolist (i (coerce (cdr (assoc c *special-chars*)) 'list))
  70                         (reschar i)))
  71                      (t (reschar c))))))
  72              (coerce (nreverse res) 'string)))
  73           (t (string-join (mapcar #'symbol-to-js symbols) ".")))))
  74
  75 ;;; js language types
  76
  77 (defmethod js-equal ((obj1 list) (obj2 list))
  78   (and (= (length obj1) (length obj2))
  79        (every #'js-equal obj1 obj2)))
  80 (defmethod js-equal ((obj1 t) (obj2 t))
  81   (equal obj1 obj2))
  82
  83 (defmacro defjsclass (name superclasses slots &rest class-options)
  84   (let ((slot-names (mapcar #'(lambda (slot) (if (atom slot) slot (first slot))) slots)))
  85     `(progn
  86       (defclass ,name ,superclasses
  87         ,slots ,@class-options)
  88       (defmethod js-equal ((obj1 ,name) (obj2 ,name))
  89         (every #'(lambda (slot)
  90                    (js-equal (slot-value obj1 slot)
  91                              (slot-value obj2 slot)))
  92                ',slot-names)))))
  93
  94 (defjsclass statement ()
  95   ((value :initarg :value :accessor value :initform nil)))
  96
  97 (defjsclass expression (statement)
  98   ((value)))
  99
 100 ;;; indenter
 101
 102 (defun special-append-to-last (form elt)
 103   (flet ((special-append (form elt)
 104            (let ((len (length form)))
 105              (if (and (> len 0)
 106                       (member (char form (1- len))
 107                               '(#\; #\, #\})))
 108                  form
 109                  (concatenate 'string form elt)))))
 110     (cond ((stringp form)
 111            (special-append form elt))
 112           ((consp form)
 113            (let ((last (last form)))
 114              (if (stringp (car last))
 115                  (rplaca last (special-append (car last) elt))
 116                  (append-to-last (car last) elt))
 117            form))
 118           (t (error "unsupported form ~S" form)))))
 119
 120 (defun dwim-join (value-string-lists max-length
 121                   &key (start "")
 122                        end
 123                        (join-before "")
 124                        join-after
 125                        (white-space (make-string (length start) :initial-element #\Space))
 126                        (separator " ")
 127                   (append-to-last #'append-to-last)
 128                   (collect t))
 129     #+nil
 130     (format t "value-string-lists: ~S~%" value-string-lists)
 131
 132     ;;; collect single value-string-lists until line full
 133
 134     (do* ((string-lists value-string-lists (cdr string-lists))
 135           (string-list (car string-lists) (car string-lists))
 136           (cur-elt start)
 137           (is-first t nil)
 138           (cur-empty t)
 139           (res nil))
 140          ((null string-lists)
 141           (unless cur-empty
 142             (push cur-elt res))
 143           (if (null res)
 144               (list (concatenate 'string start end))
 145               (progn
 146                 (when end
 147                   (setf (first res)
 148                         (funcall append-to-last (first res) end)))
 149                 (nreverse res))))
 150       #+nil
 151       (format t "string-list: ~S~%" string-list)
 152
 153       (when join-after
 154         (unless (null (cdr string-lists))
 155           (funcall append-to-last string-list join-after)))
 156
 157       (if (and collect (= (length string-list) 1))
 158           (progn
 159             #+nil
 160             (format t "cur-elt: ~S line-length ~D, max-length ~D, string: ~S~%"
 161                     cur-elt
 162                     (+ (length (first string-list))
 163                        (length cur-elt))
 164                     max-length
 165                     (first string-list))
 166             (if (or cur-empty
 167                     (< (+ (length (first string-list))
 168                           (length cur-elt)) max-length))
 169                 (setf cur-elt
 170                       (concatenate 'string cur-elt
 171                                    (if (or is-first (and cur-empty (string= join-before "")))
 172                                         "" (concatenate 'string separator join-before))
 173                                    (first string-list))
 174                       cur-empty nil)
 175                 (progn
 176                   (push cur-elt res)
 177                   (setf cur-elt (concatenate 'string white-space
 178                                              join-before (first string-list))
 179                         cur-empty nil))))
 180
 181           (progn
 182             (unless cur-empty
 183               (push cur-elt res)
 184               (setf cur-elt white-space
 185                     cur-empty t))
 186             (setf res (nconc (nreverse
 187                               (cons (concatenate 'string
 188                                                  cur-elt
 189                                                  (if (null res)
 190                                                      "" join-before)
 191                                                  (first string-list))
 192                                     (mapcar #'(lambda (x) (concatenate 'string white-space x))
 193                                             (cdr string-list))))
 194                              res))
 195             (setf cur-elt white-space cur-empty t)))))
 196
 197 (defmethod js-to-strings ((expression expression) start-pos)
 198   (declare (ignore start-pos))
 199   (list (princ-to-string (value expression))))
 200
 201 (defmethod js-to-statement-strings ((expression expression) start-pos)
 202   (js-to-strings expression start-pos))
 203
 204 (defmethod js-to-statement-strings ((statement statement) start-pos)
 205   (declare (ignore start-pos))
 206   (list (princ-to-string (value statement))))
 207
 208 ;;; compiler macros
 209
 210 (eval-when (:compile-toplevel :load-toplevel :execute)
 211   (defvar *js-compiler-macros* (make-hash-table :test 'equal)
 212         "*JS-COMPILER-MACROS* is a hash-table containing the functions corresponding
 213 to javascript special forms, indexed by their name. Javascript special
 214 forms are compiler macros for JS expressions.")
 215
 216   (defun undefine-js-compiler-macro (name)
 217     (declare (type symbol name))
 218     (when (gethash (symbol-name name) *js-compiler-macros*)
 219       (warn "Redefining compiler macro ~S" name)
 220       (remhash (symbol-name name) *js-compiler-macros*))))
 221
 222 (defmacro define-js-compiler-macro (name lambda-list &rest body)
 223   "Define a javascript compiler macro NAME. Arguments are destructured
 224 according to LAMBDA-LIST. The resulting JS language types are appended
 225 to the ongoing javascript compilation."
 226   (let ((js-name (intern (concatenate 'string "JS-" (symbol-name name)) #.*package*)))
 227     `(eval-when (:compile-toplevel :load-toplevel :execute)
 228       (defun ,js-name ,lambda-list ,@body)
 229       (setf (gethash ,(symbol-name name) *js-compiler-macros*) #',js-name))))
 230
 231 (defun js-compiler-macro-form-p (form)
 232   (when (and (symbolp (car form))
 233              (gethash (symbol-name (car form)) *js-compiler-macros*))
 234     t))
 235
 236 (defun js-get-compiler-macro (name)
 237   (when (symbolp name)
 238     (gethash (symbol-name name) *js-compiler-macros*)))
 239
 240 ;;; macro expansion
 241
 242 (eval-when (:compile-toplevel :load-toplevel :execute)
 243   (defvar *js-macro-toplevel* (make-hash-table :test 'equal)
 244     "Toplevel of macro expansion, holds all the toplevel javascript macros.")
 245   (defvar *js-macro-env* (list *js-macro-toplevel*)
 246     "Current macro environment."))
 247
 248 (defun lookup-macro (name)
 249   "Lookup the macro NAME in the current macro expansion
 250 environment. Returns the macro and the parent macro environment of
 251 this macro."
 252   (unless (symbolp name)
 253     (return-from lookup-macro nil))
 254   (do ((env *js-macro-env* (cdr env)))
 255       ((null env) nil)
 256     (let ((val (gethash (symbol-name name) (car env))))
 257       (when val
 258         (return-from lookup-macro
 259           (values val (or (cdr env)
 260                           (list *js-macro-toplevel*))))))))
 261
 262 (defmacro defjsmacro (name args &rest body)
 263   "Define a javascript macro, and store it in the toplevel macro environment."
 264   (let ((lambda-list (gensym)))
 265     (undefine-js-compiler-macro name)
 266     `(setf (gethash ,(symbol-name name) *js-macro-toplevel*)
 267       #'(lambda (&rest ,lambda-list)
 268           (destructuring-bind ,args ,lambda-list ,@body)))))
 269
 270 (defun import-macros-from-lisp (&rest names)
 271   "Import the named lisp macros into the js macro expansion"
 272   (dolist (name names)
 273     (undefine-js-compiler-macro name)
 274     (setf (gethash (symbol-name name) *js-macro-toplevel*)
 275           (lambda (&rest args)
 276             (macroexpand `(,name ,@args))))))
 277
 278 (defun js-expand-form (expr)
 279   "Expand a javascript form."
 280   (cond ((atom expr)
 281          (multiple-value-bind (js-macro macro-env)
 282              (lookup-macro expr)
 283            (if js-macro
 284                (js-expand-form (let ((*js-macro-env* macro-env))
 285                                  (funcall js-macro)))
 286                expr)))
 287
 288         ((js-compiler-macro-form-p expr) expr)
 289
 290         ((equal (first expr) 'quote) expr)
 291
 292         (t (let ((js-macro (lookup-macro (car expr))))
 293              (if js-macro
 294                  (js-expand-form (apply js-macro (cdr expr)))
 295                  expr)))))
 296
 297 (defvar *gen-js-name-counter* 0)
 298
 299 (defun gen-js-name-string (&key (prefix "_ps_"))
 300   "Generates a unique valid javascript identifier ()"
 301   (concatenate 'string
 302                prefix (princ-to-string (incf *gen-js-name-counter*))))
 303
 304 (defun gen-js-name (&key (prefix "_ps_"))
 305   "Generate a new javascript identifier."
 306   (intern (gen-js-name-string :prefix prefix)
 307           (find-package :js)))
 308
 309 (defmacro with-unique-js-names (symbols &body body)
 310   "Evaluate BODY with the variables on SYMBOLS bound to new javascript identifiers.
 311
 312 Each element of SYMBOLS is either a symbol or a list of (symbol
 313 prefix)."
 314   `(let* ,(mapcar (lambda (symbol)
 315                     (destructuring-bind (symbol &optional prefix)
 316                         (if (consp symbol)
 317                             symbol
 318                             (list symbol))
 319                       (if prefix
 320                           `(,symbol (gen-js-name :prefix ,prefix))
 321                           `(,symbol (gen-js-name)))))
 322                   symbols)
 323      ,@body))
 324
 325 (defjsmacro rebind (variables expression)
 326   ;; Creates a new js lexical environment and copies the given
 327   ;; variable(s) there.  Executes the body in the new environment. This
 328   ;; has the same effect as a new (let () ...) form in lisp but works on
 329   ;; the js side for js closures."
 330
 331   (unless (listp variables)
 332     (setf variables (list variables)))
 333   `((lambda ()
 334       (let ((new-context (new *object)))
 335         ,@(loop for variable in variables
 336                 do (setf variable (symbol-to-js variable))
 337                 collect `(setf (slot-value new-context ,variable) (slot-value this ,variable)))
 338         (with (new-context)
 339               (return ,expression))))))
 340
 341 (defvar *var-counter* 0)
 342
 343 (defun js-gensym (&optional (name "js"))
 344   (intern (format nil "tmp-~A-~A" name (incf *var-counter*)) #.*package*))
 345
 346 ;;; literals
 347
 348 (defmacro defjsliteral (name string)
 349   "Define a Javascript literal that will expand to STRING."
 350   `(define-js-compiler-macro ,name () (make-instance 'expression :value ,string)))
 351
 352 (defjsliteral this      "this")
 353 (defjsliteral t         "true")
 354 (defjsliteral nil       "null")
 355 (defjsliteral false     "false")
 356 (defjsliteral undefined "undefined")
 357
 358 (defmacro defjskeyword (name string)
 359   "Define a Javascript keyword that will expand to STRING."
 360   `(define-js-compiler-macro ,name () (make-instance 'statement :value ,string)))
 361
 362 (defjskeyword break    "break")
 363 (defjskeyword continue "continue")
 364
 365 ;;; array literals
 366
 367 (defjsclass array-literal (expression)
 368   ((values :initarg :values :accessor array-values)))
 369
 370 (define-js-compiler-macro array (&rest values)
 371   (make-instance 'array-literal
 372                  :values (mapcar #'js-compile-to-expression values)))
 373
 374 (defjsmacro list (&rest values)
 375   `(array ,@values))
 376
 377 (defmethod js-to-strings ((array array-literal) start-pos)
 378   (let ((value-string-lists
 379          (mapcar #'(lambda (x) (js-to-strings x (+ start-pos 2)))
 380                  (array-values array)))
 381         (max-length (- 80 start-pos 2)))
 382     (dwim-join value-string-lists max-length
 383                :start "[ " :end " ]"
 384                :join-after ",")))
 385
 386 (defjsclass js-aref (expression)
 387   ((array :initarg :array
 388           :accessor aref-array)
 389    (index :initarg :index
 390           :accessor aref-index)))
 391
 392 (define-js-compiler-macro aref (array &rest coords)
 393   (make-instance 'js-aref
 394                  :array (js-compile-to-expression array)
 395                  :index (mapcar #'js-compile-to-expression coords)))
 396
 397 (defmethod js-to-strings ((aref js-aref) start-pos)
 398   (dwim-join (cons (js-to-strings (aref-array aref) start-pos)
 399                    (mapcar #'(lambda (x) (dwim-join (list (js-to-strings x (+ start-pos 2)))
 400                                                     (- 80 start-pos 2)
 401                                                     :start "[" :end "]"))
 402                            (aref-index aref)))
 403              (- 80 start-pos 2) :separator ""
 404              :white-space "  "))
 405
 406 (defjsmacro make-array (&rest inits)
 407   `(new (*array ,@inits)))
 408
 409 ;;; object literals (maps and hash-tables)
 410
 411 (defjsclass object-literal (expression)
 412   ((values :initarg :values :accessor object-values)))
 413
 414 (define-js-compiler-macro {} (&rest values)
 415   (make-instance 'object-literal
 416                  :values (loop
 417                             for (key value) on values by #'cddr
 418                             collect (cons key (js-compile-to-expression value)))))
 419
 420 (defmethod js-to-strings ((obj object-literal) start-pos)
 421   (dwim-join (loop
 422                 for (key . value) in (object-values obj)
 423                 append (list
 424                         (dwim-join (list (list (format nil "~A:" (symbol-to-js key)))
 425                                          (js-to-strings value (+ start-pos 2)))
 426                                    (- 80 start-pos 2)
 427                                    :start "" :end "" :join-after "")))
 428              (- 80 start-pos 2)
 429              :start "{ " :end " }"
 430              :join-after ","))
 431
 432 ;;; string literals
 433
 434 (defjsclass string-literal (expression)
 435   (value))
 436
 437 (defvar *js-quote-char* #\'
 438   "Specifies which character JS sholud use for delimiting strings.
 439
 440 This variable is usefull when have to embed some javascript code
 441 in an html attribute delimited by #\\\" as opposed to #\\', or
 442 vice-versa.")
 443
 444 (defmethod js-to-strings ((string string-literal) start-pos)
 445   (declare (ignore start-pos)
 446            (inline lisp-special-char-to-js))
 447   (list (with-output-to-string (escaped)
 448           (write-char *js-quote-char*  escaped)
 449           (loop
 450            for char across (value string)
 451            for code = (char-code char)
 452            for special = (lisp-special-char-to-js char)
 453            do
 454            (cond
 455              (special
 456               (write-char #\\ escaped)
 457               (write-char special escaped))
 458              ((or (<= code #x1f) (>= code #x80))
 459               (format escaped "\\u~4,'0x" code))
 460              (t (write-char char escaped)))
 461            finally (write-char *js-quote-char* escaped)))))
 462
 463 (defparameter *js-lisp-escaped-chars*
 464   '((#\' . #\')
 465     (#\\ . #\\)
 466     (#\b . #\Backspace)
 467     (#\f . #.(code-char 12))
 468     (#\n . #\Newline)
 469     (#\r . #\Return)
 470     (#\t . #\Tab)))
 471
 472 (defun lisp-special-char-to-js(lisp-char)
 473     (car (rassoc lisp-char *js-lisp-escaped-chars*)))
 474
 475 ;;; number literals
 476
 477 (defjsclass number-literal (expression)
 478   (value))
 479
 480 ;;; variables
 481
 482 (defjsclass js-variable (expression)
 483   (value))
 484
 485 (defmethod js-to-strings ((v js-variable) start-form)
 486   (declare (ignore start-form))
 487   (list (symbol-to-js (value v))))
 488
 489 ;;; arithmetic operators
 490
 491 (eval-when (:compile-toplevel :load-toplevel :execute)
 492
 493   (defparameter *op-precedence-hash* (make-hash-table))
 494
 495   (defparameter *op-precedences*
 496     '((aref)
 497       (slot-value)
 498       (! not ~)
 499       (* / %)
 500       (+ -)
 501       (<< >>)
 502       (>>>)
 503       (< > <= >=)
 504       (in if)
 505       (eql == != =)
 506       (=== !==)
 507       (&)
 508       (^)
 509       (\|)
 510       (\&\& and)
 511       (\|\| or)
 512       (setf *= /= %= += -= <<= >>= >>>= \&= ^= \|=)
 513       (comma)))
 514
 515   ;;; generate the operator precedences from *OP-PRECEDENCES*
 516   (let ((precedence 1))
 517     (dolist (ops *op-precedences*)
 518       (dolist (op ops)
 519         (setf (gethash op *op-precedence-hash*) precedence))
 520       (incf precedence))))
 521
 522 (defun js-convert-op-name (op)
 523   (case op
 524     (and '\&\&)
 525     (or '\|\|)
 526     (not '!)
 527     (eql '\=\=)
 528     (=   '\=\=)
 529     (t op)))
 530
 531 (defjsclass op-form (expression)
 532   ((operator :initarg :operator :accessor operator)
 533    (args :initarg :args :accessor op-args)))
 534
 535 (defun op-form-p (form)
 536   (and (listp form)
 537        (not (js-compiler-macro-form-p form))
 538        (not (null (gethash (first form) *op-precedence-hash*)))))
 539
 540 (defun klammer (string-list)
 541   (prepend-to-first string-list "(")
 542   (append-to-last string-list ")")
 543   string-list)
 544
 545 (defmethod expression-precedence ((expression expression))
 546   0)
 547
 548 (defmethod expression-precedence ((form op-form))
 549   (gethash (operator form) *op-precedence-hash*))
 550
 551 (defmethod js-to-strings ((form op-form) start-pos)
 552   (let* ((precedence (expression-precedence form))
 553          (value-string-lists
 554           (mapcar #'(lambda (x)
 555                       (let ((string-list (js-to-strings x (+ start-pos 2))))
 556                         (if (>= (expression-precedence x) precedence)
 557                             (klammer string-list)
 558                             string-list)))
 559                   (op-args form)))
 560          (max-length (- 80 start-pos 2))
 561          (op-string (format nil "~A " (operator form))))
 562     (dwim-join value-string-lists max-length :join-before op-string)
 563     ))
 564
 565 (defjsmacro 1- (form)
 566   `(- ,form 1))
 567
 568 (defjsmacro 1+ (form)
 569   `(+ ,form 1))
 570
 571 (defjsclass one-op (expression)
 572   ((pre-p :initarg :pre-p
 573           :initform nil
 574           :accessor one-op-pre-p)
 575    (op :initarg :op
 576        :accessor one-op)))
 577
 578 (defmethod js-to-strings ((one-op one-op) start-pos)
 579   (let* ((value (value one-op))
 580          (value-strings (js-to-strings value start-pos)))
 581     (when (typep value 'op-form)
 582       (setf value-strings (klammer value-strings)))
 583     (if (one-op-pre-p one-op)
 584       (prepend-to-first value-strings
 585                         (one-op one-op))
 586       (append-to-last value-strings
 587                       (one-op one-op)))))
 588
 589 (define-js-compiler-macro incf (x)
 590   (make-instance 'one-op :pre-p t :op "++"
 591                  :value (js-compile-to-expression x)))
 592 (define-js-compiler-macro ++ (x)
 593   (make-instance 'one-op :pre-p nil :op "++"
 594                  :value (js-compile-to-expression x)))
 595 (define-js-compiler-macro decf (x)
 596   (make-instance 'one-op :pre-p t :op "--"
 597                  :value (js-compile-to-expression x)))
 598 (define-js-compiler-macro -- (x)
 599   (make-instance 'one-op :pre-p nil :op "--"
 600                  :value (js-compile-to-expression x)))
 601
 602
 603 (define-js-compiler-macro not (x)
 604   (let ((value (js-compile-to-expression x)))
 605     (if (and (typep value 'op-form)
 606              (= (length (op-args value)) 2))
 607         (let ((new-op (case (operator value)
 608                         (== '!=)
 609                         (< '>=)
 610                         (> '<=)
 611                         (<= '>)
 612                         (>= '<)
 613                         (!= '==)
 614                         (=== '!==)
 615                         (!== '===)
 616                         (t nil))))
 617           (if new-op
 618               (make-instance 'op-form :operator new-op
 619                              :args (op-args value))
 620               (make-instance 'one-op :pre-p t :op "!"
 621                             :value value)))
 622         (make-instance 'one-op :pre-p t :op "!"
 623                        :value value))))
 624
 625 ;;; function calls
 626
 627 (defjsclass function-call (expression)
 628   ((function :initarg :function :accessor f-function)
 629    (args :initarg :args :accessor f-args)))
 630
 631 (defun funcall-form-p (form)
 632   (and (listp form)
 633        (not (op-form-p form))
 634        (not (js-compiler-macro-form-p form))))
 635
 636 (defmethod js-to-strings ((form function-call) start-pos)
 637   (let* ((value-string-lists
 638           (mapcar #'(lambda (x) (js-to-strings x (+ start-pos 2)))
 639                   (f-args form)))
 640          (max-length (- 80 start-pos 2))
 641          (args (dwim-join value-string-lists max-length
 642                           :start "(" :end ")" :join-after ",")))
 643     (etypecase (f-function form)
 644       (js-lambda
 645        (dwim-join (list (append (dwim-join (list (js-to-strings (f-function form) (+ start-pos 2)))
 646                                            max-length
 647                                            :start "(" :end ")" :separator "")
 648                                 args))
 649                   max-length
 650                   :separator ""))
 651       ((or js-variable js-aref js-slot-value)
 652        (dwim-join (list (js-to-strings (f-function form) (+ start-pos 2))
 653                         args)
 654                   max-length
 655                   :separator "")))))
 656
 657 (defjsclass method-call (expression)
 658   ((method :initarg :method :accessor m-method)
 659    (object :initarg :object :accessor m-object)
 660    (args :initarg :args :accessor m-args)))
 661
 662 (defmethod js-to-strings ((form method-call) start-pos)
 663   (let ((fname (dwim-join (list (js-to-strings (m-object form) (+ start-pos 2))
 664                                 (list (symbol-to-js (m-method form))))
 665                           (- 80 start-pos 2)
 666                           :end "("
 667                           :separator "")))
 668     (let ((butlast (butlast fname))
 669           (last (car (last fname))))
 670       (nconc butlast
 671              (dwim-join (mapcar #'(lambda (x) (js-to-strings x (+ start-pos 2)))
 672                                 (m-args form))
 673                         (- 80 start-pos 2)
 674                         :start last
 675                         :end ")"
 676                         :join-after ",")))))
 677
 678 (defun method-call-p (form)
 679   (and (funcall-form-p form)
 680        (symbolp (first form))
 681        (eql (char (symbol-name (first form)) 0) #\.)))
 682
 683 ;;; body forms
 684
 685 (defjsclass js-body (expression)
 686   ((stmts :initarg :stmts :accessor b-stmts)
 687    (indent :initarg :indent :initform "" :accessor b-indent)))
 688
 689 (define-js-compiler-macro progn (&rest body)
 690   (make-instance 'js-body
 691                  :stmts (mapcar #'js-compile-to-statement body)))
 692
 693 (defmethod initialize-instance :after ((body js-body) &rest initargs)
 694   (declare (ignore initargs))
 695   (let* ((stmts (b-stmts body))
 696          (last (last stmts))
 697          (last-stmt (car last)))
 698     (when (typep last-stmt 'js-body)
 699       (setf (b-stmts body)
 700             (nconc (butlast stmts)
 701                    (b-stmts last-stmt))))))
 702
 703
 704 (defmethod js-to-statement-strings ((body js-body) start-pos)
 705   (dwim-join (mapcar #'(lambda (x) (js-to-statement-strings x (+ start-pos 2)))
 706                      (b-stmts body))
 707              (- 80 start-pos 2)
 708              :join-after ";"
 709              :append-to-last #'special-append-to-last
 710              :start (b-indent body) :collect nil
 711              :end ";"))
 712
 713 (defmethod js-to-strings ((body js-body) start-pos)
 714   (dwim-join (mapcar #'(lambda (x) (js-to-strings x (+ start-pos 2)))
 715                      (b-stmts body))
 716              (- 80 start-pos 2)
 717              :append-to-last #'special-append-to-last
 718              :join-after ","
 719              :start (b-indent body)))
 720
 721 (defjsclass js-sub-body (js-body)
 722   (stmts indent))
 723
 724 (defmethod js-to-statement-strings ((body js-sub-body) start-pos)
 725   (declare (ignore start-pos))
 726   (nconc (list "{") (call-next-method) (list "}")))
 727
 728 (defmethod expression-precedence ((body js-body))
 729   (if (= (length (b-stmts body)) 1)
 730       (expression-precedence (first (b-stmts body)))
 731       (gethash 'comma *op-precedence-hash*)))
 732
 733 ;;; function definition
 734
 735 (defjsclass js-lambda (expression)
 736   ((args :initarg :args :accessor lambda-args)
 737    (body :initarg :body :accessor lambda-body)))
 738
 739 (define-js-compiler-macro lambda (args &rest body)
 740   (make-instance 'js-lambda
 741                  :args (mapcar #'js-compile-to-symbol args)
 742                  :body (make-instance 'js-body
 743                                       :indent "  "
 744                                       :stmts (mapcar #'js-compile-to-statement body))))
 745
 746 (defmethod js-to-strings ((lambda js-lambda) start-pos)
 747   (let ((fun-header (dwim-join (mapcar #'(lambda (x)
 748                                            (list (symbol-to-js x)))
 749                                        (lambda-args lambda))
 750                                (- 80 start-pos 2)
 751                                :start (function-start-string lambda)
 752                                :end ") {" :join-after ","))
 753         (fun-body (js-to-statement-strings (lambda-body lambda) (+ start-pos 2))))
 754     (nconc fun-header fun-body (list "}"))))
 755
 756 (defmethod function-start-string ((lambda js-lambda))
 757   "function (")
 758
 759 (defmethod js-to-statement-strings ((lambda js-lambda) start-pos)
 760   (js-to-strings lambda start-pos))
 761
 762 (defjsclass js-defun (js-lambda)
 763   ((name :initarg :name :accessor defun-name)))
 764
 765 (define-js-compiler-macro defun (name args &rest body)
 766   (make-instance 'js-defun
 767                  :name (js-compile-to-symbol name)
 768                  :args (mapcar #'js-compile-to-symbol args)
 769                  :body (make-instance 'js-body
 770                                       :indent "  "
 771                                       :stmts (mapcar #'js-compile-to-statement body))))
 772
 773 (defmethod function-start-string ((defun js-defun))
 774   (format nil "function ~A(" (symbol-to-js (defun-name defun))))
 775
 776 ;;; object creation
 777
 778 (defjsclass js-object (expression)
 779   ((slots :initarg :slots
 780           :accessor o-slots)))
 781
 782 (define-js-compiler-macro create (&rest args)
 783   (make-instance 'js-object
 784                  :slots (loop for (name val) on args by #'cddr
 785                               collect (list (js-compile-to-symbol name)
 786                                             (js-compile-to-expression val)))))
 787
 788 (defmethod js-to-strings ((object js-object) start-pos)
 789   (let ((value-string-lists
 790          (mapcar #'(lambda (slot)
 791                      (dwim-join (list (js-to-strings (second slot) (+ start-pos 4)))
 792                                 (- 80 start-pos 2)
 793                                 :start (concatenate 'string (symbol-to-js (first slot)) " : ")
 794                                 :white-space "    ")) (o-slots object)))
 795         (max-length (- 80 start-pos 2)))
 796     (dwim-join value-string-lists max-length
 797                :start "{ "
 798                :end " }"
 799                :join-after ", "
 800                :white-space "  "
 801                :collect nil)))
 802
 803 (defjsclass js-slot-value (expression)
 804   ((object :initarg :object
 805            :accessor sv-object)
 806    (slot :initarg :slot
 807          :accessor sv-slot)))
 808
 809 (define-js-compiler-macro slot-value (obj slot)
 810   (make-instance 'js-slot-value :object (js-compile-to-expression obj)
 811                    :slot (js-compile slot)))
 812
 813 (defmethod js-to-strings ((sv js-slot-value) start-pos)
 814   (append-to-last (js-to-strings (sv-object sv) start-pos)
 815                   (if (symbolp (sv-slot sv))
 816                       (format nil ".~A" (symbol-to-js (sv-slot sv)))
 817                       (format nil "[~A]" (first (js-to-strings (sv-slot sv) 0))))))
 818
 819 (defjsmacro with-slots (slots object &rest body)
 820   `(symbol-macrolet ,(mapcar #'(lambda (slot)
 821                                  `(,slot '(slot-value ,object ',slot)))
 822                              slots)
 823     ,@body))
 824
 825 ;;; macros
 826
 827 (define-js-compiler-macro macrolet (macros &rest body)
 828   (let* ((macro-env (make-hash-table :test 'equal))
 829          (*js-macro-env* (cons macro-env *js-macro-env*)))
 830     (dolist (macro macros)
 831       (destructuring-bind (name arglist &rest body) macro
 832         (setf (gethash (symbol-name name) macro-env)
 833               (compile nil `(lambda ,arglist ,@body)))))
 834     (js-compile `(progn ,@body))))
 835
 836 (defjsmacro symbol-macrolet (macros &rest body)
 837   `(macrolet ,(mapcar #'(lambda (macro)
 838                           `(,(first macro) () ,@(rest macro))) macros)
 839     ,@body))
 840
 841 ;;; lisp eval
 842
 843 (defjsmacro lisp (&rest forms)
 844   (eval (cons 'progn forms)))
 845
 846 ;;; if
 847
 848 (defjsclass js-if (expression)
 849   ((test :initarg :test
 850          :accessor if-test)
 851    (then :initarg :then
 852          :accessor if-then)
 853    (else :initarg :else
 854          :accessor if-else)))
 855
 856 (define-js-compiler-macro if (test then &optional else)
 857   (make-instance 'js-if :test (js-compile-to-expression test)
 858                  :then (js-compile-to-body then :indent "  ")
 859                  :else (when else
 860                          (js-compile-to-body else :indent "  "))))
 861
 862 (defmethod initialize-instance :after ((if js-if) &rest initargs)
 863   (declare (ignore initargs))
 864   (when (and (if-then if)
 865              (typep (if-then if) 'js-sub-body))
 866     (change-class (if-then if) 'js-body))
 867   (when (and (if-else if)
 868              (typep (if-else if) 'js-sub-body))
 869     (change-class (if-else if) 'js-body)))
 870
 871 (defmethod js-to-statement-strings ((if js-if) start-pos)
 872   (let ((if-strings (dwim-join (list (js-to-strings (if-test if) 0))
 873                                (- 80 start-pos 2)
 874                                :start "if ("
 875                                :end ") {"))
 876         (then-strings (js-to-statement-strings (if-then if) (+ start-pos 2)))
 877         (else-strings (when (if-else if)
 878                         (js-to-statement-strings (if-else if)
 879                                                  (+ start-pos 2)))))
 880     (nconc if-strings then-strings (if else-strings
 881                                        (nconc (list "} else {") else-strings (list "}"))
 882                                        (list "}")))))
 883
 884 (defmethod expression-precedence ((if js-if))
 885   (gethash 'if *op-precedence-hash*))
 886
 887 (defmethod js-to-strings ((if js-if) start-pos)
 888   (assert (typep (if-then if) 'expression))
 889   (when (if-else if)
 890     (assert (typep (if-else if) 'expression)))
 891   (dwim-join (list (append-to-last (js-to-strings (if-test if) start-pos) " ?")
 892                    (let* ((new-then (make-instance 'js-body
 893                                                    :stmts (b-stmts (if-then if))
 894                                                    :indent ""))
 895                           (res (js-to-strings new-then start-pos)))
 896                      (if (>= (expression-precedence (if-then if))
 897                              (expression-precedence if))
 898                              (klammer res)
 899                              res))
 900                    (list ":")
 901                    (if (if-else if)
 902                        (let* ((new-else (make-instance 'js-body
 903                                                        :stmts (b-stmts (if-else if))
 904                                                        :indent ""))
 905                               (res (js-to-strings new-else start-pos)))
 906                          (if (>= (expression-precedence (if-else if))
 907                                  (expression-precedence if))
 908                              (klammer res)
 909                              res))
 910                        (list "undefined")))
 911              (- 80 start-pos 2)
 912              :white-space "  "))
 913
 914 (defjsmacro when (test &rest body)
 915   `(if ,test (progn ,@body)))
 916
 917 (defjsmacro unless (test &rest body)
 918   `(if (not ,test) (progn ,@body)))
 919
 920 ;;; single keyword expressions and statements
 921
 922 (defmacro define-js-single-op (name &optional (superclass 'expression))
 923   (let ((js-name (intern (concatenate 'string "JS-" (symbol-name name)) #.*package*)))
 924   `(progn
 925     (defjsclass ,js-name (,superclass)
 926       (value))
 927     (define-js-compiler-macro ,name (value)
 928       (make-instance ',js-name :value (js-compile-to-expression value)))
 929     (defmethod ,(if (eql superclass 'expression)
 930                     'js-to-strings
 931                     'js-to-statement-strings) ((,name ,js-name) start-pos)
 932       (dwim-join (list (js-to-strings (value ,name) (+ start-pos 2)))
 933                  (- 80 start-pos 2)
 934                  :start ,(concatenate 'string (string-downcase (symbol-name name)) " ")
 935                  :white-space "  ")))))
 936
 937
 938 (define-js-single-op return statement)
 939 (define-js-single-op throw statement)
 940 (define-js-single-op delete)
 941 (define-js-single-op void)
 942 (define-js-single-op typeof)
 943 (define-js-single-op instanceof)
 944 (define-js-single-op new)
 945
 946 ;;; assignment
 947
 948 (defjsclass js-setf (expression)
 949   ((lhs :initarg :lhs :accessor setf-lhs)
 950    (rhsides :initarg :rhsides :accessor setf-rhsides)))
 951
 952 (defun assignment-op (op)
 953   (case op
 954     (+ '+=)
 955     (~ '~=)
 956     (\& '\&=)
 957     (\| '\|=)
 958     (- '-=)
 959     (* '*=)
 960     (% '%=)
 961     (>> '>>=)
 962     (^  '^=)
 963     (<< '<<=)
 964     (>>> '>>>=)
 965     (/   '/=)
 966     (t   nil)))
 967
 968 (defun make-js-test (lhs rhs)
 969   (if (and (typep rhs 'op-form)
 970            (member lhs (op-args rhs) :test #'js-equal))
 971       (let ((args-without (remove lhs (op-args rhs)
 972                                   :count 1 :test #'js-equal))
 973             (args-without-first (remove lhs (op-args rhs)
 974                                         :count 1 :end 1
 975                                         :test #'js-equal))
 976             (one (list (make-instance 'number-literal :value 1))))
 977         #+nil
 978         (format t "OPERATOR: ~S, ARGS-WITHOUT: ~S, ARGS-WITHOUT-FIRST ~S~%"
 979                 (operator rhs)
 980                 args-without
 981                 args-without-first)
 982         (cond ((and (js-equal args-without one)
 983                     (eql (operator rhs) '+))
 984                (make-instance 'one-op :pre-p nil :op "++"
 985                               :value lhs))
 986               ((and (js-equal args-without-first one)
 987                     (eql (operator rhs) '-))
 988                (make-instance 'one-op :pre-p nil :op "--"
 989                               :value lhs))
 990               ((and (assignment-op (operator rhs))
 991                     (member (operator rhs)
 992                             '(+ *)))
 993                (make-instance 'op-form
 994                               :operator (assignment-op (operator rhs))
 995                               :args (list lhs (make-instance 'op-form
 996                                                              :operator (operator rhs)
 997                                                              :args args-without))))
 998               ((and (assignment-op (operator rhs))
 999                     (js-equal (first (op-args rhs)) lhs))
1000                (make-instance 'op-form
1001                               :operator (assignment-op (operator rhs))
1002                               :args (list lhs (make-instance 'op-form
1003                                                              :operator (operator rhs)
1004                                                              :args (cdr (op-args rhs))))))
1005               (t (make-instance 'js-setf :lhs lhs :rhsides (list rhs)))))
1006       (make-instance 'js-setf :lhs lhs :rhsides (list rhs))))
1007
1008 (define-js-compiler-macro setf (&rest args)
1009   (let ((assignments (loop for (lhs rhs) on args by #'cddr
1010                            for rexpr = (js-compile-to-expression rhs)
1011                            for lexpr = (js-compile-to-expression lhs)
1012                            collect (make-js-test lexpr rexpr))))
1013     (if (= (length assignments) 1)
1014         (first assignments)
1015         (make-instance 'js-body :indent "" :stmts assignments))))
1016
1017 (defmethod js-to-strings ((setf js-setf) start-pos)
1018   (dwim-join (cons (js-to-strings (setf-lhs setf) start-pos)
1019                    (mapcar #'(lambda (x) (js-to-strings x start-pos)) (setf-rhsides setf)))
1020              (- 80 start-pos 2)
1021              :join-after " ="))
1022
1023 (defmethod expression-precedence ((setf js-setf))
1024   (gethash '= *op-precedence-hash*))
1025
1026 ;;; defvar
1027
1028 (defjsclass js-defvar (statement)
1029   ((names :initarg :names :accessor var-names)
1030    (value :initarg :value :accessor var-value)))
1031
1032 (define-js-compiler-macro defvar (name &optional value)
1033   (make-instance 'js-defvar :names (list (js-compile-to-symbol name))
1034                  :value (when value (js-compile-to-expression value))))
1035
1036 (defmethod js-to-statement-strings ((defvar js-defvar) start-pos)
1037   (dwim-join (nconc (mapcar #'(lambda (x) (list (symbol-to-js x))) (var-names defvar))
1038                     (when (var-value defvar)
1039                       (list (js-to-strings (var-value defvar) start-pos))))
1040              (- 80 start-pos 2)
1041              :join-after " ="
1042              :start "var " :end ";"))
1043
1044 ;;; let
1045
1046 (define-js-compiler-macro let (decls &rest body)
1047   (let ((single-defvar (make-instance 'js-defvar
1048                                       :names (mapcar #'js-compile-to-symbol
1049                                                      (remove-if-not #'atom decls))
1050                                       :value nil))
1051         (defvars (mapcar #'(lambda (decl)
1052                              (let ((name (first decl))
1053                                    (value (second decl)))
1054                              (make-instance 'js-defvar
1055                                             :names (list (js-compile-to-symbol name))
1056                                             :value (js-compile-to-expression value))))
1057                          (remove-if #'atom decls))))
1058     (make-instance 'js-sub-body
1059                    :indent "  "
1060                    :stmts (nconc (when (var-names single-defvar) (list single-defvar))
1061                                  defvars
1062                                  (mapcar #'js-compile-to-statement body)))))
1063
1064 ;;; iteration
1065
1066 (defjsclass js-for (statement)
1067   ((vars :initarg :vars :accessor for-vars)
1068    (steps :initarg :steps :accessor for-steps)
1069    (check :initarg :check :accessor for-check)
1070    (body :initarg :body :accessor for-body)))
1071
1072 (defun make-for-vars (decls)
1073   (loop for decl in decls
1074         for var = (if (atom decl) decl (first decl))
1075         for init = (if (atom decl) nil (second decl))
1076         collect (make-instance 'js-defvar :names (list (js-compile-to-symbol var))
1077                                :value (js-compile-to-expression init))))
1078
1079 (defun make-for-steps (decls)
1080   (loop for decl in decls
1081         when (= (length decl) 3)
1082         collect (js-compile-to-expression (third decl))))
1083
1084 (define-js-compiler-macro do (decls termination &rest body)
1085   (let ((vars (make-for-vars decls))
1086         (steps (make-for-steps decls))
1087         (check (js-compile-to-expression (list 'not (first termination))))
1088         (body (js-compile-to-body (cons 'progn body) :indent "  ")))
1089     (make-instance 'js-for
1090                    :vars vars
1091                    :steps steps
1092                    :check check
1093                    :body body)))
1094
1095 (defjsmacro dotimes (iter &rest body)
1096   (let ((var (first iter))
1097         (times (second iter)))
1098   `(do ((,var 0 (1+ ,var)))
1099        ((>= ,var ,times))
1100      ,@body)))
1101
1102 (defjsmacro dolist (i-array &rest body)
1103   (let ((var (first i-array))
1104         (array (second i-array))
1105         (arrvar (js-gensym "arr"))
1106         (idx (js-gensym "i")))
1107     `(let ((,arrvar ,array))
1108       (do ((,idx 0 (1+ ,idx)))
1109           ((>= ,idx (slot-value ,arrvar 'length)))
1110         (let ((,var (aref ,arrvar ,idx)))
1111           ,@body)))))
1112
1113 (defjsmacro map-into (function array)
1114   "Call FUNCTION on each element in ARRAY, replace element with the return value."
1115   ;; be friendly to both (map-into 'foo array) and (map-into foo array) calls
1116   (when (and (listp function)
1117              (eq 'quote (first function)))
1118     (setf function (eval function)))
1119   (with-unique-js-names (arrvar idx fn)
1120     `((lambda ()
1121         (let ((,arrvar ,array)
1122               (,fn ,function))
1123           (do ((,idx 0 (1+ ,idx)))
1124               ((>= ,idx (slot-value ,arrvar 'length)))
1125             (setf (aref ,arrvar ,idx) (,fn (aref ,arrvar ,idx)))))
1126         (return ,arrvar)))))
1127
1128 (defjsmacro map (function array)
1129   "Call FUNCTION on each element in ARRAY and return the returned values in a new array."
1130   ;; be friendly to both (map 'foo array) and (map foo array) calls
1131   (when (and (listp function)
1132              (eq 'quote (first function)))
1133     (setf function (eval function)))
1134   (with-unique-js-names (arrvar result idx fn)
1135     `((lambda ()
1136         (let ((,arrvar ,array)
1137               (,fn ,function)
1138               (,result (make-array (slot-value ,arrvar 'length))))
1139           (do ((,idx 0 (1+ ,idx)))
1140               ((>= ,idx (slot-value ,arrvar 'length)))
1141             (setf (aref ,result ,idx) (,fn (aref ,arrvar ,idx)))))
1142         (return ,result)))))
1143
1144 (defmethod js-to-statement-strings ((for js-for) start-pos)
1145   (let* ((init (dwim-join (mapcar #'(lambda (x)
1146                                       (dwim-join (list (list (symbol-to-js (first (var-names x))))
1147                                                        (js-to-strings (var-value x)
1148                                                                       (+ start-pos 2)))
1149                                                  (- 80 start-pos 2)
1150                                                  :join-after " ="))
1151                                   (for-vars for))
1152                           (- 80 start-pos 2)
1153                           :start "var " :join-after ","))
1154          (check (js-to-strings (for-check for) (+ start-pos 2)))
1155          (steps (dwim-join (mapcar #'(lambda (x var)
1156                                        (dwim-join
1157                                         (list (list (symbol-to-js (first (var-names var))))
1158                                               (js-to-strings x (- start-pos 2)))
1159                                         (- 80 start-pos 2)
1160                                         :join-after " ="))
1161                                    (for-steps for)
1162                                    (for-vars for))
1163                            (- 80 start-pos 2)
1164                            :join-after ","))
1165          (header (dwim-join (list init check steps)
1166                             (- 80 start-pos 2)
1167                             :start "for (" :end ") {"
1168                             :join-after ";"))
1169          (body (js-to-statement-strings (for-body for) (+ start-pos 2))))
1170     (nconc header body (list "}"))))
1171
1172 (defjsclass for-each (statement)
1173   ((name :initarg :name :accessor fe-name)
1174    (value :initarg :value :accessor fe-value)
1175    (body :initarg :body :accessor fe-body)))
1176
1177 (define-js-compiler-macro doeach (decl &rest body)
1178   (make-instance 'for-each :name (js-compile-to-symbol (first decl))
1179                  :value (js-compile-to-expression (second decl))
1180                  :body (js-compile-to-body (cons 'progn body) :indent "  ")))
1181
1182 (defmethod js-to-statement-strings ((fe for-each) start-pos)
1183   (let ((header (dwim-join (list (list (symbol-to-js (fe-name fe)))
1184                                  (list "in")
1185                                  (js-to-strings (fe-value fe) (+ start-pos 2)))
1186                            (- 80 start-pos 2)
1187                            :start "for (var "
1188                            :end ") {"))
1189         (body (js-to-statement-strings (fe-body fe) (+ start-pos 2))))
1190     (nconc header body (list "}"))))
1191
1192 (defjsclass js-while (statement)
1193   ((check :initarg :check :accessor while-check)
1194    (body :initarg :body :accessor while-body)))
1195
1196 (define-js-compiler-macro while (check &rest body)
1197   (make-instance 'js-while
1198                  :check (js-compile-to-expression check)
1199                  :body (js-compile-to-body (cons 'progn body) :indent "  ")))
1200
1201 (defmethod js-to-statement-strings ((while js-while) start-pos)
1202   (let ((header (dwim-join (list (js-to-strings (while-check while) (+ start-pos 2)))
1203                            (- 80 start-pos 2)
1204                            :start "while ("
1205                            :end ") {"))
1206         (body (js-to-statement-strings (while-body while) (+ start-pos 2))))
1207     (nconc header body (list "}"))))
1208
1209 ;;; with
1210
1211 (defjsclass js-with (statement)
1212   ((obj :initarg :obj :accessor with-obj)
1213    (body :initarg :body :accessor with-body)))
1214
1215 (define-js-compiler-macro with (statement &rest body)
1216   (make-instance 'js-with
1217                  :obj (js-compile-to-expression (first statement))
1218                  :body (js-compile-to-body (cons 'progn body) :indent "  ")))
1219
1220 (defmethod js-to-statement-strings ((with js-with) start-pos)
1221   (nconc (dwim-join (list (js-to-strings (with-obj with) (+ start-pos 2)))
1222                     (- 80 start-pos 2)
1223                     :start "with (" :end ") {")
1224          (js-to-statement-strings (with-body with) (+ start-pos 2))
1225          (list "}")))
1226
1227 ;;; case
1228
1229 (defjsclass js-switch (statement)
1230   ((value :initarg :value :accessor case-value)
1231    (clauses :initarg :clauses :accessor case-clauses)))
1232
1233 (define-js-compiler-macro switch (value &rest clauses)
1234   (let ((clauses (mapcar #'(lambda (clause)
1235                              (let ((val (first clause))
1236                                    (body (cdr clause)))
1237                                (list (if (eql val 'default)
1238                                          'default
1239                                          (js-compile-to-expression val))
1240                                      (js-compile-to-body (cons 'progn body) :indent "  "))))
1241                          clauses))
1242         (check (js-compile-to-expression value)))
1243     (make-instance 'js-switch :value check
1244                    :clauses clauses)))
1245
1246 (defmethod js-to-statement-strings ((case js-switch) start-pos)
1247   (let ((body    (mapcan #'(lambda (clause)
1248                      (let ((val (car clause))
1249                            (body (second clause)))
1250                        (dwim-join (list (if (eql val 'default)
1251                                             (list "")
1252                                             (js-to-strings val (+ start-pos 2)))
1253                                         (js-to-statement-strings body (+ start-pos 2)))
1254                                   (- 80 start-pos 2)
1255                                   :start (if (eql val 'default) "  default" "  case ")
1256                                   :white-space "   "
1257                                   :join-after ":"))) (case-clauses case))))
1258
1259     #+nil
1260     (format t "body: ~S~%" body)
1261     (nconc (dwim-join (list (js-to-strings (case-value case) (+ start-pos 2)))
1262                     (- 80 start-pos 2)
1263                     :start "switch (" :end ") {")
1264            body
1265            (list "}"))))
1266
1267 (defjsmacro case (value &rest clauses)
1268   (labels ((make-clause (val body more)
1269              (cond ((listp val)
1270                     (append (mapcar #'list (butlast val))
1271                             (make-clause (first (last val)) body more)))
1272                    ((member val '(t otherwise))
1273                     (make-clause 'default body more))
1274                    (more `((,val ,@body break)))
1275                    (t `((,val ,@body))))))
1276     `(switch ,value ,@(mapcon #'(lambda (x)
1277                                   (make-clause (car (first x))
1278                                                (cdr (first x))
1279                                                (rest x)))
1280                               clauses))))
1281
1282 ;;; throw catch
1283
1284 (defjsclass js-try (statement)
1285   ((body :initarg :body :accessor try-body)
1286    (catch :initarg :catch :accessor try-catch)
1287    (finally :initarg :finally :accessor try-finally)))
1288
1289 (define-js-compiler-macro try (body &rest clauses)
1290   (let ((body (js-compile-to-body body :indent "  "))
1291         (catch (cdr (assoc :catch clauses)))
1292         (finally (cdr (assoc :finally clauses))))
1293     (make-instance 'js-try
1294                    :body body
1295                    :catch (when catch (list (js-compile-to-symbol (caar catch))
1296                                             (js-compile-to-body (cons 'progn (cdr catch))
1297                                                                 :indent "  ")))
1298                    :finally (when finally (js-compile-to-body (cons 'progn finally)
1299                                                               :indent "  ")))))
1300
1301 (defmethod js-to-statement-strings ((try js-try) start-pos)
1302   (let* ((catch (try-catch try))
1303          (finally (try-finally try))
1304          (catch-list (when catch
1305                        (nconc
1306                         (dwim-join (list (list (symbol-to-js (first catch))))
1307                                    (- 80 start-pos 2)
1308                                    :start "} catch ("
1309                                    :end ") {")
1310                         (js-to-statement-strings (second catch) (+ start-pos 2)))))
1311          (finally-list (when finally
1312                          (nconc (list "} finally {")
1313                                 (js-to-statement-strings finally (+ start-pos 2))))))
1314     (nconc (list "try {")
1315            (js-to-statement-strings (try-body try) (+ start-pos 2))
1316            catch-list
1317            finally-list
1318            (list "}"))))
1319
1320 ;;; regex
1321
1322 (defjsclass regex (expression)
1323   (value))
1324
1325 (define-js-compiler-macro regex (regex)
1326   (make-instance 'regex :value (string regex)))
1327
1328 (defmethod js-to-strings ((regex regex) start-pos)
1329   (declare (ignore start-pos))
1330   (list (format nil "/~A/" (value regex))))
1331
1332 ;;; conditional compilation
1333
1334 (defjsclass cc-if ()
1335   ((test :initarg :test :accessor cc-if-test)
1336    (body :initarg :body :accessor cc-if-body)))
1337
1338 (defmethod js-to-statement-strings ((cc cc-if) start-pos)
1339   (nconc (list (format nil "/*@if ~A" (cc-if-test cc)))
1340          (mapcan #'(lambda (x) (js-to-strings x start-pos)) (cc-if-body cc))
1341          (list "@end @*/")))
1342
1343 (define-js-compiler-macro cc-if (test &rest body)
1344   (make-instance 'cc-if :test test
1345                  :body (mapcar #'js-compile body)))
1346
1347 ;;; compiler
1348
1349 (defun js-compile (form)
1350   (setf form (js-expand-form form))
1351   (cond ((stringp form)
1352          (make-instance 'string-literal :value form))
1353         ((characterp form)
1354          (make-instance 'string-literal :value (string form)))
1355         ((numberp form)
1356          (make-instance 'number-literal :value form))
1357         ((symbolp form)
1358          (let ((c-macro (js-get-compiler-macro form)))
1359            (if c-macro
1360                (funcall c-macro)
1361                (make-instance 'js-variable :value form))))
1362         ((and (consp form)
1363               (eql (first form) 'quote))
1364          (second form))
1365         ((consp form)
1366          (js-compile-list form))
1367         (t (error "Unknown atomar expression ~S" form))))
1368
1369 (defun js-compile-list (form)
1370   (let* ((name (car form))
1371          (args (cdr form))
1372          (js-form (js-get-compiler-macro name)))
1373     (cond (js-form
1374            (apply js-form args))
1375
1376           ((op-form-p form)
1377            (make-instance 'op-form
1378                           :operator (js-convert-op-name (js-compile-to-symbol (first form)))
1379                           :args (mapcar #'js-compile-to-expression (rest form))))
1380
1381           ((method-call-p form)
1382            (make-instance 'method-call
1383                           :method (js-compile-to-symbol (first form))
1384                           :object (js-compile-to-expression (second form))
1385                           :args (mapcar #'js-compile-to-expression (cddr form))))
1386
1387           ((funcall-form-p form)
1388            (make-instance 'function-call
1389                           :function (js-compile-to-expression (first form))
1390                           :args (mapcar #'js-compile-to-expression (rest form))))
1391
1392           (t (error "Unknown form ~S" form)))))
1393
1394 (defun js-compile-to-expression (form)
1395   (let ((res (js-compile form)))
1396     (assert (typep res 'expression))
1397     res))
1398
1399 (defun js-compile-to-symbol (form)
1400   (let ((res (js-compile form)))
1401     (when (typep res 'js-variable )
1402       (setf res (value res)))
1403     (assert (symbolp res))
1404     res))
1405
1406 (defun js-compile-to-statement (form)
1407   (let ((res (js-compile form)))
1408     (assert (typep res 'statement))
1409     res))
1410
1411 (defun js-compile-to-body (form &key (indent ""))
1412   (let ((res (js-compile-to-statement form)))
1413     (if (typep res 'js-body)
1414         (progn (setf (b-indent res) indent)
1415                res)
1416         (make-instance 'js-body
1417                        :indent indent
1418                        :stmts (list res)))))
1419
1420 ;;; Math library
1421
1422 (defjsmacro floor (expr)
1423   `(*Math.floor ,expr))
1424
1425 (defjsmacro random ()
1426   `(*Math.random))
1427
1428 ;;; helper macros
1429
1430 (define-js-compiler-macro js (&rest body)
1431   (make-instance 'string-literal
1432                  :value (string-join (js-to-statement-strings
1433                                       (js-compile (cons 'progn body)) 0) " ")))
1434
1435 (define-js-compiler-macro js-inline (&rest body)
1436   (make-instance 'string-literal
1437                  :value (concatenate
1438                          'string
1439                          "javascript:"
1440                          (string-join (js-to-statement-strings
1441                                        (js-compile (cons 'progn body)) 0) " "))))
1442
1443
1444 (defmacro js (&rest body)
1445   `(js* '(progn ,@body)))
1446
1447 (defmacro js* (&rest body)
1448   "Return the javascript string representing BODY.
1449
1450 Body is evaluated."
1451   `(string-join
1452     (js-to-statement-strings (js-compile (list 'progn ,@body)) 0)
1453     (string #\Newline)))
1454
1455 (defun js-to-string (expr)
1456   (string-join
1457    (js-to-statement-strings (js-compile expr) 0)
1458    (string #\Newline)))
1459
1460 (defun js-to-line (expr)
1461   (string-join
1462    (js-to-statement-strings (js-compile expr) 0) " "))
1463
1464 (defmacro js-file (&rest body)
1465   `(html
1466     (:princ
1467      (js ,@body))))
1468
1469 (defmacro js-script (&rest body)
1470   `((:script :type "text/javascript")
1471     (:princ (format nil "~%// <![CDATA[~%"))
1472     (:princ (js ,@body))
1473     (:princ (format nil "~%// ]]>~%"))))
1474
1475 (defmacro js-inline (&rest body)
1476   `(js-inline* '(progn ,@body)))
1477
1478 (defmacro js-inline* (&rest body)
1479   "Just like JS-INLINE except that BODY is evaluated before being
1480 converted to javascript."
1481   `(concatenate 'string "javascript:"
1482     (string-join (js-to-statement-strings (js-compile (list 'progn ,@body)) 0) " ")))
1483