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                       (string= (char form (1- len)) elt))
 107                  form
 108                  (concatenate 'string form elt)))))
 109     (cond ((stringp form)
 110            (special-append form elt))
 111           ((consp form)
 112            (let ((last (last form)))
 113              (if (stringp (car last))
 114                  (rplaca last (special-append (car last) elt))
 115                  (append-to-last (car last) elt))
 116            form))
 117           (t (error "unsupported form ~S" form)))))
 118
 119 (defun dwim-join (value-string-lists max-length
 120                   &key (start "")
 121                        end
 122                        (join-before "")
 123                        join-after
 124                        (white-space (make-string (length start) :initial-element #\Space))
 125                        (separator " ")
 126                   (append-to-last #'append-to-last)
 127                   (collect t))
 128     #+nil
 129     (format t "value-string-lists: ~S~%" value-string-lists)
 130
 131     ;;; collect single value-string-lists until line full
 132
 133     (do* ((string-lists value-string-lists (cdr string-lists))
 134           (string-list (car string-lists) (car string-lists))
 135           (cur-elt start)
 136           (is-first t nil)
 137           (cur-empty t)
 138           (res nil))
 139          ((null string-lists)
 140           (unless cur-empty
 141             (push cur-elt res))
 142           (if (null res)
 143               (list (concatenate 'string start end))
 144               (progn
 145                 (when end
 146                   (setf (first res)
 147                         (funcall append-to-last (first res) end)))
 148                 (nreverse res))))
 149       #+nil
 150       (format t "string-list: ~S~%" string-list)
 151
 152       (when join-after
 153         (unless (null (cdr string-lists))
 154           (funcall append-to-last string-list join-after)))
 155
 156       (if (and collect (= (length string-list) 1))
 157           (progn
 158             #+nil
 159             (format t "cur-elt: ~S line-length ~D, max-length ~D, string: ~S~%"
 160                     cur-elt
 161                     (+ (length (first string-list))
 162                        (length cur-elt))
 163                     max-length
 164                     (first string-list))
 165             (if (or cur-empty
 166                     (< (+ (length (first string-list))
 167                           (length cur-elt)) max-length))
 168                 (setf cur-elt
 169                       (concatenate 'string cur-elt
 170                                    (if (or is-first (and cur-empty (string= join-before "")))
 171                                         "" (concatenate 'string separator join-before))
 172                                    (first string-list))
 173                       cur-empty nil)
 174                 (progn
 175                   (push cur-elt res)
 176                   (setf cur-elt (concatenate 'string white-space
 177                                              join-before (first string-list))
 178                         cur-empty nil))))
 179
 180           (progn
 181             (unless cur-empty
 182               (push cur-elt res)
 183               (setf cur-elt white-space
 184                     cur-empty t))
 185             (setf res (nconc (nreverse
 186                               (cons (concatenate 'string
 187                                                  cur-elt
 188                                                  (if (null res)
 189                                                      "" join-before)
 190                                                  (first string-list))
 191                                     (mapcar #'(lambda (x) (concatenate 'string white-space x))
 192                                             (cdr string-list))))
 193                              res))
 194             (setf cur-elt white-space cur-empty t)))))
 195
 196 (defmethod js-to-strings ((expression expression) start-pos)
 197   (declare (ignore start-pos))
 198   (list (princ-to-string (value expression))))
 199
 200 (defmethod js-to-statement-strings ((expression expression) start-pos)
 201   (js-to-strings expression start-pos))
 202
 203 (defmethod js-to-statement-strings ((statement statement) start-pos)
 204   (declare (ignore start-pos))
 205   (list (princ-to-string (value statement))))
 206
 207 ;;; compiler macros
 208
 209 (eval-when (:compile-toplevel :load-toplevel :execute)
 210   (defvar *js-compiler-macros* (make-hash-table :test 'equal)
 211         "*JS-COMPILER-MACROS* is a hash-table containing the functions corresponding
 212 to javascript special forms, indexed by their name. Javascript special
 213 forms are compiler macros for JS expressions.")
 214
 215   (defun undefine-js-compiler-macro (name)
 216     (declare (type symbol name))
 217     (when (gethash (symbol-name name) *js-compiler-macros*)
 218       (warn "Redefining compiler macro ~S" name)
 219       (remhash (symbol-name name) *js-compiler-macros*))))
 220
 221 (defmacro define-js-compiler-macro (name lambda-list &rest body)
 222   "Define a javascript compiler macro NAME. Arguments are destructured
 223 according to LAMBDA-LIST. The resulting JS language types are appended
 224 to the ongoing javascript compilation."
 225   (let ((js-name (intern (concatenate 'string "JS-" (symbol-name name)) #.*package*)))
 226     `(eval-when (:compile-toplevel :load-toplevel :execute)
 227       (defun ,js-name ,lambda-list ,@body)
 228       (setf (gethash ,(symbol-name name) *js-compiler-macros*) #',js-name))))
 229
 230 (defun js-compiler-macro-form-p (form)
 231   (when (and (symbolp (car form))
 232              (gethash (symbol-name (car form)) *js-compiler-macros*))
 233     t))
 234
 235 (defun js-get-compiler-macro (name)
 236   (when (symbolp name)
 237     (gethash (symbol-name name) *js-compiler-macros*)))
 238
 239 ;;; macro expansion
 240
 241 (eval-when (:compile-toplevel :load-toplevel :execute)
 242   (defvar *js-macro-toplevel* (make-hash-table :test 'equal)
 243     "Toplevel of macro expansion, holds all the toplevel javascript macros.")
 244   (defvar *js-macro-env* (list *js-macro-toplevel*)
 245     "Current macro environment."))
 246
 247 (defun lookup-macro (name)
 248   "Lookup the macro NAME in the current macro expansion
 249 environment. Returns the macro and the parent macro environment of
 250 this macro."
 251   (unless (symbolp name)
 252     (return-from lookup-macro nil))
 253   (do ((env *js-macro-env* (cdr env)))
 254       ((null env) nil)
 255     (let ((val (gethash (symbol-name name) (car env))))
 256       (when val
 257         (return-from lookup-macro
 258           (values val (or (cdr env)
 259                           (list *js-macro-toplevel*))))))))
 260
 261 (defmacro defjsmacro (name args &rest body)
 262   "Define a javascript macro, and store it in the toplevel macro environment."
 263   (let ((lambda-list (gensym)))
 264     (undefine-js-compiler-macro name)
 265     `(setf (gethash ,(symbol-name name) *js-macro-toplevel*)
 266       #'(lambda (&rest ,lambda-list)
 267           (destructuring-bind ,args ,lambda-list ,@body)))))
 268
 269 (defun import-macros-from-lisp (&rest names)
 270   "Import the named lisp macros into the js macro expansion"
 271   (dolist (name names)
 272     (let ((name name))
 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 new)
 944
 945 ;; TODO this may not be the best integrated implementation of
 946 ;; instanceof into the rest of the code
 947 (defjsclass js-instanceof (expression)
 948   ((value)
 949    (type :initarg :type)))
 950
 951 (define-js-compiler-macro instanceof (value type)
 952   (make-instance 'js-instanceof
 953                  :value (js-compile-to-expression value)
 954                  :type (js-compile-to-expression type)))
 955
 956 (defmethod js-to-strings ((instanceof js-instanceof) start-pos)
 957   (dwim-join
 958    (list (js-to-strings (value instanceof) (+ start-pos 2))
 959          (list "instanceof")
 960          (js-to-strings (slot-value instanceof 'type) (+ start-pos 2)))
 961    (- 80 start-pos 2)
 962    :white-space
 963    "  "))
 964
 965 ;;; assignment
 966
 967 (defjsclass js-setf (expression)
 968   ((lhs :initarg :lhs :accessor setf-lhs)
 969    (rhsides :initarg :rhsides :accessor setf-rhsides)))
 970
 971 (defun assignment-op (op)
 972   (case op
 973     (+ '+=)
 974     (~ '~=)
 975     (\& '\&=)
 976     (\| '\|=)
 977     (- '-=)
 978     (* '*=)
 979     (% '%=)
 980     (>> '>>=)
 981     (^  '^=)
 982     (<< '<<=)
 983     (>>> '>>>=)
 984     (/   '/=)
 985     (t   nil)))
 986
 987 (defun make-js-test (lhs rhs)
 988   (if (and (typep rhs 'op-form)
 989            (member lhs (op-args rhs) :test #'js-equal))
 990       (let ((args-without (remove lhs (op-args rhs)
 991                                   :count 1 :test #'js-equal))
 992             (args-without-first (remove lhs (op-args rhs)
 993                                         :count 1 :end 1
 994                                         :test #'js-equal))
 995             (one (list (make-instance 'number-literal :value 1))))
 996         #+nil
 997         (format t "OPERATOR: ~S, ARGS-WITHOUT: ~S, ARGS-WITHOUT-FIRST ~S~%"
 998                 (operator rhs)
 999                 args-without
1000                 args-without-first)
1001         (cond ((and (js-equal args-without one)
1002                     (eql (operator rhs) '+))
1003                (make-instance 'one-op :pre-p nil :op "++"
1004                               :value lhs))
1005               ((and (js-equal args-without-first one)
1006                     (eql (operator rhs) '-))
1007                (make-instance 'one-op :pre-p nil :op "--"
1008                               :value lhs))
1009               ((and (assignment-op (operator rhs))
1010                     (member (operator rhs)
1011                             '(+ *)))
1012                (make-instance 'op-form
1013                               :operator (assignment-op (operator rhs))
1014                               :args (list lhs (make-instance 'op-form
1015                                                              :operator (operator rhs)
1016                                                              :args args-without))))
1017               ((and (assignment-op (operator rhs))
1018                     (js-equal (first (op-args rhs)) lhs))
1019                (make-instance 'op-form
1020                               :operator (assignment-op (operator rhs))
1021                               :args (list lhs (make-instance 'op-form
1022                                                              :operator (operator rhs)
1023                                                              :args (cdr (op-args rhs))))))
1024               (t (make-instance 'js-setf :lhs lhs :rhsides (list rhs)))))
1025       (make-instance 'js-setf :lhs lhs :rhsides (list rhs))))
1026
1027 (define-js-compiler-macro setf (&rest args)
1028   (let ((assignments (loop for (lhs rhs) on args by #'cddr
1029                            for rexpr = (js-compile-to-expression rhs)
1030                            for lexpr = (js-compile-to-expression lhs)
1031                            collect (make-js-test lexpr rexpr))))
1032     (if (= (length assignments) 1)
1033         (first assignments)
1034         (make-instance 'js-body :indent "" :stmts assignments))))
1035
1036 (defmethod js-to-strings ((setf js-setf) start-pos)
1037   (dwim-join (cons (js-to-strings (setf-lhs setf) start-pos)
1038                    (mapcar #'(lambda (x) (js-to-strings x start-pos)) (setf-rhsides setf)))
1039              (- 80 start-pos 2)
1040              :join-after " ="))
1041
1042 (defmethod expression-precedence ((setf js-setf))
1043   (gethash '= *op-precedence-hash*))
1044
1045 ;;; defvar
1046
1047 (defjsclass js-defvar (statement)
1048   ((names :initarg :names :accessor var-names)
1049    (value :initarg :value :accessor var-value)))
1050
1051 (define-js-compiler-macro defvar (name &optional value)
1052   (make-instance 'js-defvar :names (list (js-compile-to-symbol name))
1053                  :value (when value (js-compile-to-expression value))))
1054
1055 (defmethod js-to-statement-strings ((defvar js-defvar) start-pos)
1056   (dwim-join (nconc (mapcar #'(lambda (x) (list (symbol-to-js x))) (var-names defvar))
1057                     (when (var-value defvar)
1058                       (list (js-to-strings (var-value defvar) start-pos))))
1059              (- 80 start-pos 2)
1060              :join-after " ="
1061              :start "var " :end ";"))
1062
1063 ;;; let
1064
1065 (define-js-compiler-macro let (decls &rest body)
1066   (let ((single-defvar (make-instance 'js-defvar
1067                                       :names (mapcar #'js-compile-to-symbol
1068                                                      (remove-if-not #'atom decls))
1069                                       :value nil))
1070         (defvars (mapcar #'(lambda (decl)
1071                              (let ((name (first decl))
1072                                    (value (second decl)))
1073                              (make-instance 'js-defvar
1074                                             :names (list (js-compile-to-symbol name))
1075                                             :value (js-compile-to-expression value))))
1076                          (remove-if #'atom decls))))
1077     (make-instance 'js-sub-body
1078                    :indent "  "
1079                    :stmts (nconc (when (var-names single-defvar) (list single-defvar))
1080                                  defvars
1081                                  (mapcar #'js-compile-to-statement body)))))
1082
1083 ;;; iteration
1084
1085 (defjsclass js-for (statement)
1086   ((vars :initarg :vars :accessor for-vars)
1087    (steps :initarg :steps :accessor for-steps)
1088    (check :initarg :check :accessor for-check)
1089    (body :initarg :body :accessor for-body)))
1090
1091 (defun make-for-vars (decls)
1092   (loop for decl in decls
1093         for var = (if (atom decl) decl (first decl))
1094         for init = (if (atom decl) nil (second decl))
1095         collect (make-instance 'js-defvar :names (list (js-compile-to-symbol var))
1096                                :value (js-compile-to-expression init))))
1097
1098 (defun make-for-steps (decls)
1099   (loop for decl in decls
1100         when (= (length decl) 3)
1101         collect (js-compile-to-expression (third decl))))
1102
1103 (define-js-compiler-macro do (decls termination &rest body)
1104   (let ((vars (make-for-vars decls))
1105         (steps (make-for-steps decls))
1106         (check (js-compile-to-expression (list 'not (first termination))))
1107         (body (js-compile-to-body (cons 'progn body) :indent "  ")))
1108     (make-instance 'js-for
1109                    :vars vars
1110                    :steps steps
1111                    :check check
1112                    :body body)))
1113
1114 (defjsmacro dotimes (iter &rest body)
1115   (let ((var (first iter))
1116         (times (second iter)))
1117   `(do ((,var 0 (1+ ,var)))
1118        ((>= ,var ,times))
1119      ,@body)))
1120
1121 (defjsmacro dolist (i-array &rest body)
1122   (let ((var (first i-array))
1123         (array (second i-array))
1124         (arrvar (js-gensym "arr"))
1125         (idx (js-gensym "i")))
1126     `(let ((,arrvar ,array))
1127       (do ((,idx 0 (1+ ,idx)))
1128           ((>= ,idx (slot-value ,arrvar 'length)))
1129         (let ((,var (aref ,arrvar ,idx)))
1130           ,@body)))))
1131
1132 (defmethod js-to-statement-strings ((for js-for) start-pos)
1133   (let* ((init (dwim-join (mapcar #'(lambda (x)
1134                                       (dwim-join (list (list (symbol-to-js (first (var-names x))))
1135                                                        (js-to-strings (var-value x)
1136                                                                       (+ start-pos 2)))
1137                                                  (- 80 start-pos 2)
1138                                                  :join-after " ="))
1139                                   (for-vars for))
1140                           (- 80 start-pos 2)
1141                           :start "var " :join-after ","))
1142          (check (js-to-strings (for-check for) (+ start-pos 2)))
1143          (steps (dwim-join (mapcar #'(lambda (x var)
1144                                        (dwim-join
1145                                         (list (list (symbol-to-js (first (var-names var))))
1146                                               (js-to-strings x (- start-pos 2)))
1147                                         (- 80 start-pos 2)
1148                                         :join-after " ="))
1149                                    (for-steps for)
1150                                    (for-vars for))
1151                            (- 80 start-pos 2)
1152                            :join-after ","))
1153          (header (dwim-join (list init check steps)
1154                             (- 80 start-pos 2)
1155                             :start "for (" :end ") {"
1156                             :join-after ";"))
1157          (body (js-to-statement-strings (for-body for) (+ start-pos 2))))
1158     (nconc header body (list "}"))))
1159
1160 (defjsclass for-each (statement)
1161   ((name :initarg :name :accessor fe-name)
1162    (value :initarg :value :accessor fe-value)
1163    (body :initarg :body :accessor fe-body)))
1164
1165 (define-js-compiler-macro doeach (decl &rest body)
1166   (make-instance 'for-each :name (js-compile-to-symbol (first decl))
1167                  :value (js-compile-to-expression (second decl))
1168                  :body (js-compile-to-body (cons 'progn body) :indent "  ")))
1169
1170 (defmethod js-to-statement-strings ((fe for-each) start-pos)
1171   (let ((header (dwim-join (list (list (symbol-to-js (fe-name fe)))
1172                                  (list "in")
1173                                  (js-to-strings (fe-value fe) (+ start-pos 2)))
1174                            (- 80 start-pos 2)
1175                            :start "for (var "
1176                            :end ") {"))
1177         (body (js-to-statement-strings (fe-body fe) (+ start-pos 2))))
1178     (nconc header body (list "}"))))
1179
1180 (defjsclass js-while (statement)
1181   ((check :initarg :check :accessor while-check)
1182    (body :initarg :body :accessor while-body)))
1183
1184 (define-js-compiler-macro while (check &rest body)
1185   (make-instance 'js-while
1186                  :check (js-compile-to-expression check)
1187                  :body (js-compile-to-body (cons 'progn body) :indent "  ")))
1188
1189 (defmethod js-to-statement-strings ((while js-while) start-pos)
1190   (let ((header (dwim-join (list (js-to-strings (while-check while) (+ start-pos 2)))
1191                            (- 80 start-pos 2)
1192                            :start "while ("
1193                            :end ") {"))
1194         (body (js-to-statement-strings (while-body while) (+ start-pos 2))))
1195     (nconc header body (list "}"))))
1196
1197 ;;; with
1198
1199 (defjsclass js-with (statement)
1200   ((obj :initarg :obj :accessor with-obj)
1201    (body :initarg :body :accessor with-body)))
1202
1203 (define-js-compiler-macro with (statement &rest body)
1204   (make-instance 'js-with
1205                  :obj (js-compile-to-expression statement)
1206                  :body (js-compile-to-body (cons 'progn body) :indent "  ")))
1207
1208 (defmethod js-to-statement-strings ((with js-with) start-pos)
1209   (nconc (dwim-join (list (js-to-strings (with-obj with) (+ start-pos 2)))
1210                     (- 80 start-pos 2)
1211                     :start "with (" :end ") {")
1212          (js-to-statement-strings (with-body with) (+ start-pos 2))
1213          (list "}")))
1214
1215 ;;; case
1216
1217 (defjsclass js-switch (statement)
1218   ((value :initarg :value :accessor case-value)
1219    (clauses :initarg :clauses :accessor case-clauses)))
1220
1221 (define-js-compiler-macro switch (value &rest clauses)
1222   (let ((clauses (mapcar #'(lambda (clause)
1223                              (let ((val (first clause))
1224                                    (body (cdr clause)))
1225                                (list (if (eql val 'default)
1226                                          'default
1227                                          (js-compile-to-expression val))
1228                                      (js-compile-to-body (cons 'progn body) :indent "  "))))
1229                          clauses))
1230         (check (js-compile-to-expression value)))
1231     (make-instance 'js-switch :value check
1232                    :clauses clauses)))
1233
1234 (defmethod js-to-statement-strings ((case js-switch) start-pos)
1235   (let ((body    (mapcan #'(lambda (clause)
1236                      (let ((val (car clause))
1237                            (body (second clause)))
1238                        (dwim-join (list (if (eql val 'default)
1239                                             (list "")
1240                                             (js-to-strings val (+ start-pos 2)))
1241                                         (js-to-statement-strings body (+ start-pos 2)))
1242                                   (- 80 start-pos 2)
1243                                   :start (if (eql val 'default) "  default" "  case ")
1244                                   :white-space "   "
1245                                   :join-after ":"))) (case-clauses case))))
1246
1247     #+nil
1248     (format t "body: ~S~%" body)
1249     (nconc (dwim-join (list (js-to-strings (case-value case) (+ start-pos 2)))
1250                     (- 80 start-pos 2)
1251                     :start "switch (" :end ") {")
1252            body
1253            (list "}"))))
1254
1255 (defjsmacro case (value &rest clauses)
1256   (labels ((make-clause (val body more)
1257              (cond ((listp val)
1258                     (append (mapcar #'list (butlast val))
1259                             (make-clause (first (last val)) body more)))
1260                    ((member val '(t otherwise))
1261                     (make-clause 'default body more))
1262                    (more `((,val ,@body break)))
1263                    (t `((,val ,@body))))))
1264     `(switch ,value ,@(mapcon #'(lambda (x)
1265                                   (make-clause (car (first x))
1266                                                (cdr (first x))
1267                                                (rest x)))
1268                               clauses))))
1269
1270 ;;; throw catch
1271
1272 (defjsclass js-try (statement)
1273   ((body :initarg :body :accessor try-body)
1274    (catch :initarg :catch :accessor try-catch)
1275    (finally :initarg :finally :accessor try-finally)))
1276
1277 (define-js-compiler-macro try (body &rest clauses)
1278   (let ((body (js-compile-to-body body :indent "  "))
1279         (catch (cdr (assoc :catch clauses)))
1280         (finally (cdr (assoc :finally clauses))))
1281     (make-instance 'js-try
1282                    :body body
1283                    :catch (when catch (list (js-compile-to-symbol (caar catch))
1284                                             (js-compile-to-body (cons 'progn (cdr catch))
1285                                                                 :indent "  ")))
1286                    :finally (when finally (js-compile-to-body (cons 'progn finally)
1287                                                               :indent "  ")))))
1288
1289 (defmethod js-to-statement-strings ((try js-try) start-pos)
1290   (let* ((catch (try-catch try))
1291          (finally (try-finally try))
1292          (catch-list (when catch
1293                        (nconc
1294                         (dwim-join (list (list (symbol-to-js (first catch))))
1295                                    (- 80 start-pos 2)
1296                                    :start "} catch ("
1297                                    :end ") {")
1298                         (js-to-statement-strings (second catch) (+ start-pos 2)))))
1299          (finally-list (when finally
1300                          (nconc (list "} finally {")
1301                                 (js-to-statement-strings finally (+ start-pos 2))))))
1302     (nconc (list "try {")
1303            (js-to-statement-strings (try-body try) (+ start-pos 2))
1304            catch-list
1305            finally-list
1306            (list "}"))))
1307
1308 ;;; regex
1309
1310 (defjsclass regex (expression)
1311   (value))
1312
1313 (define-js-compiler-macro regex (regex)
1314   (make-instance 'regex :value (string regex)))
1315
1316 (defun first-slash-p (string)
1317   (and (> (length string) 0)
1318        (eq (char string 0) '#\/)))
1319
1320 (defmethod js-to-strings ((regex regex) start-pos)
1321    (declare (ignore start-pos))
1322    (let ((slash (if (first-slash-p (value regex)) nil "/")))
1323      (list (format nil (concatenate 'string slash "~A" slash) (value regex)))))
1324
1325 ;;; conditional compilation
1326
1327 (defjsclass cc-if ()
1328   ((test :initarg :test :accessor cc-if-test)
1329    (body :initarg :body :accessor cc-if-body)))
1330
1331 (defmethod js-to-statement-strings ((cc cc-if) start-pos)
1332   (nconc (list (format nil "/*@if ~A" (cc-if-test cc)))
1333          (mapcan #'(lambda (x) (js-to-strings x start-pos)) (cc-if-body cc))
1334          (list "@end @*/")))
1335
1336 (define-js-compiler-macro cc-if (test &rest body)
1337   (make-instance 'cc-if :test test
1338                  :body (mapcar #'js-compile body)))
1339
1340 ;;; compiler
1341
1342 (defun js-compile (form)
1343   (setf form (js-expand-form form))
1344   (cond ((stringp form)
1345          (make-instance 'string-literal :value form))
1346         ((characterp form)
1347          (make-instance 'string-literal :value (string form)))
1348         ((numberp form)
1349          (make-instance 'number-literal :value form))
1350         ((symbolp form)
1351          (let ((c-macro (js-get-compiler-macro form)))
1352            (if c-macro
1353                (funcall c-macro)
1354                (make-instance 'js-variable :value form))))
1355         ((and (consp form)
1356               (eql (first form) 'quote))
1357          (second form))
1358         ((consp form)
1359          (js-compile-list form))
1360         (t (error "Unknown atomar expression ~S" form))))
1361
1362 (defun js-compile-list (form)
1363   (let* ((name (car form))
1364          (args (cdr form))
1365          (js-form (js-get-compiler-macro name)))
1366     (cond (js-form
1367            (apply js-form args))
1368
1369           ((op-form-p form)
1370            (make-instance 'op-form
1371                           :operator (js-convert-op-name (js-compile-to-symbol (first form)))
1372                           :args (mapcar #'js-compile-to-expression (rest form))))
1373
1374           ((method-call-p form)
1375            (make-instance 'method-call
1376                           :method (js-compile-to-symbol (first form))
1377                           :object (js-compile-to-expression (second form))
1378                           :args (mapcar #'js-compile-to-expression (cddr form))))
1379
1380           ((funcall-form-p form)
1381            (make-instance 'function-call
1382                           :function (js-compile-to-expression (first form))
1383                           :args (mapcar #'js-compile-to-expression (rest form))))
1384
1385           (t (error "Unknown form ~S" form)))))
1386
1387 (defun js-compile-to-expression (form)
1388   (let ((res (js-compile form)))
1389     (assert (typep res 'expression))
1390     res))
1391
1392 (defun js-compile-to-symbol (form)
1393   (let ((res (js-compile form)))
1394     (when (typep res 'js-variable )
1395       (setf res (value res)))
1396     (assert (symbolp res))
1397     res))
1398
1399 (defun js-compile-to-statement (form)
1400   (let ((res (js-compile form)))
1401     (assert (typep res 'statement))
1402     res))
1403
1404 (defun js-compile-to-body (form &key (indent ""))
1405   (let ((res (js-compile-to-statement form)))
1406     (if (typep res 'js-body)
1407         (progn (setf (b-indent res) indent)
1408                res)
1409         (make-instance 'js-body
1410                        :indent indent
1411                        :stmts (list res)))))
1412
1413 ;;; Math library
1414
1415 (defjsmacro floor (expr)
1416   `(*Math.floor ,expr))
1417
1418 (defjsmacro random ()
1419   `(*Math.random))
1420
1421 ;;; helper macros
1422
1423 (define-js-compiler-macro js (&rest body)
1424   (make-instance 'string-literal
1425                  :value (string-join (js-to-statement-strings
1426                                       (js-compile (cons 'progn body)) 0) " ")))
1427
1428 (define-js-compiler-macro js-inline (&rest body)
1429   (make-instance 'string-literal
1430                  :value (concatenate
1431                          'string
1432                          "javascript:"
1433                          (string-join (js-to-statement-strings
1434                                        (js-compile (cons 'progn body)) 0) " "))))
1435
1436
1437 (defmacro js (&rest body)
1438   `(js* '(progn ,@body)))
1439
1440 (defmacro js* (&rest body)
1441   "Return the javascript string representing BODY.
1442
1443 Body is evaluated."
1444   `(string-join
1445     (js-to-statement-strings (js-compile (list 'progn ,@body)) 0)
1446     (string #\Newline)))
1447
1448 (defun js-to-string (expr)
1449   (string-join
1450    (js-to-statement-strings (js-compile expr) 0)
1451    (string #\Newline)))
1452
1453 (defun js-to-line (expr)
1454   (string-join
1455    (js-to-statement-strings (js-compile expr) 0) " "))
1456
1457 (defmacro js-file (&rest body)
1458   `(html
1459     (:princ
1460      (js ,@body))))
1461
1462 (defmacro js-script (&rest body)
1463   `((:script :type "text/javascript")
1464     (:princ (format nil "~%// <![CDATA[~%"))
1465     (:princ (js ,@body))
1466     (:princ (format nil "~%// ]]>~%"))))
1467
1468 (defmacro js-inline (&rest body)
1469   `(js-inline* '(progn ,@body)))
1470
1471 (defmacro js-inline* (&rest body)
1472   "Just like JS-INLINE except that BODY is evaluated before being
1473 converted to javascript."
1474   `(concatenate 'string "javascript:"
1475     (string-join (js-to-statement-strings (js-compile (list 'progn ,@body)) 0) " ")))
1476