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