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       (function-call
 657        ;; TODO it adds superfluous newlines after each ()
 658        ;; and it's nearly the same as the js-lambda case above
 659        (dwim-join (list (append (dwim-join (list (js-to-strings (f-function form) (+ start-pos 2)))
 660                                            max-length :separator "")
 661                                 args))
 662                   max-length :separator "")))))
 663
 664 (defjsclass method-call (expression)
 665   ((method :initarg :method :accessor m-method)
 666    (object :initarg :object :accessor m-object)
 667    (args :initarg :args :accessor m-args)))
 668
 669 (defmethod js-to-strings ((form method-call) start-pos)
 670   (let ((fname (dwim-join (list (js-to-strings (m-object form) (+ start-pos 2))
 671                                 (list (symbol-to-js (m-method form))))
 672                           (- 80 start-pos 2)
 673                           :end "("
 674                           :separator "")))
 675     (let ((butlast (butlast fname))
 676           (last (car (last fname))))
 677       (nconc butlast
 678              (dwim-join (mapcar #'(lambda (x) (js-to-strings x (+ start-pos 2)))
 679                                 (m-args form))
 680                         (- 80 start-pos 2)
 681                         :start last
 682                         :end ")"
 683                         :join-after ",")))))
 684
 685 (defun method-call-p (form)
 686   (and (funcall-form-p form)
 687        (symbolp (first form))
 688        (eql (char (symbol-name (first form)) 0) #\.)))
 689
 690 ;;; body forms
 691
 692 (defjsclass js-body (expression)
 693   ((stmts :initarg :stmts :accessor b-stmts)
 694    (indent :initarg :indent :initform "" :accessor b-indent)))
 695
 696 (define-js-compiler-macro progn (&rest body)
 697   (make-instance 'js-body
 698                  :stmts (mapcar #'js-compile-to-statement body)))
 699
 700 (defmethod initialize-instance :after ((body js-body) &rest initargs)
 701   (declare (ignore initargs))
 702   (let* ((stmts (b-stmts body))
 703          (last (last stmts))
 704          (last-stmt (car last)))
 705     (when (typep last-stmt 'js-body)
 706       (setf (b-stmts body)
 707             (nconc (butlast stmts)
 708                    (b-stmts last-stmt))))))
 709
 710
 711 (defmethod js-to-statement-strings ((body js-body) start-pos)
 712   (dwim-join (mapcar #'(lambda (x) (js-to-statement-strings x (+ start-pos 2)))
 713                      (b-stmts body))
 714              (- 80 start-pos 2)
 715              :join-after ";"
 716              :append-to-last #'special-append-to-last
 717              :start (b-indent body) :collect nil
 718              :end ";"))
 719
 720 (defmethod js-to-strings ((body js-body) start-pos)
 721   (dwim-join (mapcar #'(lambda (x) (js-to-strings x (+ start-pos 2)))
 722                      (b-stmts body))
 723              (- 80 start-pos 2)
 724              :append-to-last #'special-append-to-last
 725              :join-after ","
 726              :start (b-indent body)))
 727
 728 (defjsclass js-sub-body (js-body)
 729   (stmts indent))
 730
 731 (defmethod js-to-statement-strings ((body js-sub-body) start-pos)
 732   (declare (ignore start-pos))
 733   (nconc (list "{") (call-next-method) (list "}")))
 734
 735 (defmethod expression-precedence ((body js-body))
 736   (if (= (length (b-stmts body)) 1)
 737       (expression-precedence (first (b-stmts body)))
 738       (gethash 'comma *op-precedence-hash*)))
 739
 740 ;;; function definition
 741
 742 (defjsclass js-lambda (expression)
 743   ((args :initarg :args :accessor lambda-args)
 744    (body :initarg :body :accessor lambda-body)))
 745
 746 (define-js-compiler-macro lambda (args &rest body)
 747   (make-instance 'js-lambda
 748                  :args (mapcar #'js-compile-to-symbol args)
 749                  :body (make-instance 'js-body
 750                                       :indent "  "
 751                                       :stmts (mapcar #'js-compile-to-statement body))))
 752
 753 (defmethod js-to-strings ((lambda js-lambda) start-pos)
 754   (let ((fun-header (dwim-join (mapcar #'(lambda (x)
 755                                            (list (symbol-to-js x)))
 756                                        (lambda-args lambda))
 757                                (- 80 start-pos 2)
 758                                :start (function-start-string lambda)
 759                                :end ") {" :join-after ","))
 760         (fun-body (js-to-statement-strings (lambda-body lambda) (+ start-pos 2))))
 761     (nconc fun-header fun-body (list "}"))))
 762
 763 (defmethod function-start-string ((lambda js-lambda))
 764   "function (")
 765
 766 (defmethod js-to-statement-strings ((lambda js-lambda) start-pos)
 767   (js-to-strings lambda start-pos))
 768
 769 (defjsclass js-defun (js-lambda)
 770   ((name :initarg :name :accessor defun-name)))
 771
 772 (define-js-compiler-macro defun (name args &rest body)
 773   (make-instance 'js-defun
 774                  :name (js-compile-to-symbol name)
 775                  :args (mapcar #'js-compile-to-symbol args)
 776                  :body (make-instance 'js-body
 777                                       :indent "  "
 778                                       :stmts (mapcar #'js-compile-to-statement body))))
 779
 780 (defmethod function-start-string ((defun js-defun))
 781   (format nil "function ~A(" (symbol-to-js (defun-name defun))))
 782
 783 ;;; object creation
 784
 785 (defjsclass js-object (expression)
 786   ((slots :initarg :slots
 787           :accessor o-slots)))
 788
 789 (define-js-compiler-macro create (&rest args)
 790   (make-instance 'js-object
 791                  :slots (loop for (name val) on args by #'cddr
 792                               collect (list (js-compile-to-symbol name)
 793                                             (js-compile-to-expression val)))))
 794
 795 (defmethod js-to-strings ((object js-object) start-pos)
 796   (let ((value-string-lists
 797          (mapcar #'(lambda (slot)
 798                      (dwim-join (list (js-to-strings (second slot) (+ start-pos 4)))
 799                                 (- 80 start-pos 2)
 800                                 :start (concatenate 'string (symbol-to-js (first slot)) " : ")
 801                                 :white-space "    ")) (o-slots object)))
 802         (max-length (- 80 start-pos 2)))
 803     (dwim-join value-string-lists max-length
 804                :start "{ "
 805                :end " }"
 806                :join-after ", "
 807                :white-space "  "
 808                :collect nil)))
 809
 810 (defjsclass js-slot-value (expression)
 811   ((object :initarg :object
 812            :accessor sv-object)
 813    (slot :initarg :slot
 814          :accessor sv-slot)))
 815
 816 (define-js-compiler-macro slot-value (obj slot)
 817   (make-instance 'js-slot-value :object (js-compile-to-expression obj)
 818                    :slot (js-compile slot)))
 819
 820 (defmethod js-to-strings ((sv js-slot-value) start-pos)
 821   (append-to-last (js-to-strings (sv-object sv) start-pos)
 822                   (if (symbolp (sv-slot sv))
 823                       (format nil ".~A" (symbol-to-js (sv-slot sv)))
 824                       (format nil "[~A]" (first (js-to-strings (sv-slot sv) 0))))))
 825
 826 (defjsmacro with-slots (slots object &rest body)
 827   `(symbol-macrolet ,(mapcar #'(lambda (slot)
 828                                  `(,slot '(slot-value ,object ',slot)))
 829                              slots)
 830     ,@body))
 831
 832 ;;; macros
 833
 834 (define-js-compiler-macro macrolet (macros &rest body)
 835   (let* ((macro-env (make-hash-table :test 'equal))
 836          (*js-macro-env* (cons macro-env *js-macro-env*)))
 837     (dolist (macro macros)
 838       (destructuring-bind (name arglist &rest body) macro
 839         (setf (gethash (symbol-name name) macro-env)
 840               (compile nil `(lambda ,arglist ,@body)))))
 841     (js-compile `(progn ,@body))))
 842
 843 (defjsmacro symbol-macrolet (macros &rest body)
 844   `(macrolet ,(mapcar #'(lambda (macro)
 845                           `(,(first macro) () ,@(rest macro))) macros)
 846     ,@body))
 847
 848 ;;; lisp eval
 849
 850 (defjsmacro lisp (&rest forms)
 851   (eval (cons 'progn forms)))
 852
 853 ;;; if
 854
 855 (defjsclass js-if (expression)
 856   ((test :initarg :test
 857          :accessor if-test)
 858    (then :initarg :then
 859          :accessor if-then)
 860    (else :initarg :else
 861          :accessor if-else)))
 862
 863 (define-js-compiler-macro if (test then &optional else)
 864   (make-instance 'js-if :test (js-compile-to-expression test)
 865                  :then (js-compile-to-body then :indent "  ")
 866                  :else (when else
 867                          (js-compile-to-body else :indent "  "))))
 868
 869 (defmethod initialize-instance :after ((if js-if) &rest initargs)
 870   (declare (ignore initargs))
 871   (when (and (if-then if)
 872              (typep (if-then if) 'js-sub-body))
 873     (change-class (if-then if) 'js-body))
 874   (when (and (if-else if)
 875              (typep (if-else if) 'js-sub-body))
 876     (change-class (if-else if) 'js-body)))
 877
 878 (defmethod js-to-statement-strings ((if js-if) start-pos)
 879   (let ((if-strings (dwim-join (list (js-to-strings (if-test if) 0))
 880                                (- 80 start-pos 2)
 881                                :start "if ("
 882                                :end ") {"))
 883         (then-strings (js-to-statement-strings (if-then if) (+ start-pos 2)))
 884         (else-strings (when (if-else if)
 885                         (js-to-statement-strings (if-else if)
 886                                                  (+ start-pos 2)))))
 887     (nconc if-strings then-strings (if else-strings
 888                                        (nconc (list "} else {") else-strings (list "}"))
 889                                        (list "}")))))
 890
 891 (defmethod expression-precedence ((if js-if))
 892   (gethash 'if *op-precedence-hash*))
 893
 894 (defmethod js-to-strings ((if js-if) start-pos)
 895   (assert (typep (if-then if) 'expression))
 896   (when (if-else if)
 897     (assert (typep (if-else if) 'expression)))
 898   (dwim-join (list (append-to-last (js-to-strings (if-test if) start-pos) " ?")
 899                    (let* ((new-then (make-instance 'js-body
 900                                                    :stmts (b-stmts (if-then if))
 901                                                    :indent ""))
 902                           (res (js-to-strings new-then start-pos)))
 903                      (if (>= (expression-precedence (if-then if))
 904                              (expression-precedence if))
 905                              (klammer res)
 906                              res))
 907                    (list ":")
 908                    (if (if-else if)
 909                        (let* ((new-else (make-instance 'js-body
 910                                                        :stmts (b-stmts (if-else if))
 911                                                        :indent ""))
 912                               (res (js-to-strings new-else start-pos)))
 913                          (if (>= (expression-precedence (if-else if))
 914                                  (expression-precedence if))
 915                              (klammer res)
 916                              res))
 917                        (list "undefined")))
 918              (- 80 start-pos 2)
 919              :white-space "  "))
 920
 921 (defjsmacro when (test &rest body)
 922   `(if ,test (progn ,@body)))
 923
 924 (defjsmacro unless (test &rest body)
 925   `(if (not ,test) (progn ,@body)))
 926
 927 ;;; single keyword expressions and statements
 928
 929 (defmacro define-js-single-op (name &optional (superclass 'expression))
 930   (let ((js-name (intern (concatenate 'string "JS-" (symbol-name name)) #.*package*)))
 931   `(progn
 932     (defjsclass ,js-name (,superclass)
 933       (value))
 934     (define-js-compiler-macro ,name (value)
 935       (make-instance ',js-name :value (js-compile-to-expression value)))
 936     (defmethod ,(if (eql superclass 'expression)
 937                     'js-to-strings
 938                     'js-to-statement-strings) ((,name ,js-name) start-pos)
 939       (dwim-join (list (js-to-strings (value ,name) (+ start-pos 2)))
 940                  (- 80 start-pos 2)
 941                  :start ,(concatenate 'string (string-downcase (symbol-name name)) " ")
 942                  :white-space "  ")))))
 943
 944
 945 (define-js-single-op return statement)
 946 (define-js-single-op throw statement)
 947 (define-js-single-op delete)
 948 (define-js-single-op void)
 949 (define-js-single-op typeof)
 950 (define-js-single-op new)
 951
 952 ;; TODO this may not be the best integrated implementation of
 953 ;; instanceof into the rest of the code
 954 (defjsclass js-instanceof (expression)
 955   ((value)
 956    (type :initarg :type)))
 957
 958 (define-js-compiler-macro instanceof (value type)
 959   (make-instance 'js-instanceof
 960                  :value (js-compile-to-expression value)
 961                  :type (js-compile-to-expression type)))
 962
 963 (defmethod js-to-strings ((instanceof js-instanceof) start-pos)
 964   (dwim-join
 965    (list (js-to-strings (value instanceof) (+ start-pos 2))
 966          (list "instanceof")
 967          (js-to-strings (slot-value instanceof 'type) (+ start-pos 2)))
 968    (- 80 start-pos 2)
 969    :white-space
 970    "  "))
 971
 972 ;;; assignment
 973
 974 (defjsclass js-setf (expression)
 975   ((lhs :initarg :lhs :accessor setf-lhs)
 976    (rhsides :initarg :rhsides :accessor setf-rhsides)))
 977
 978 (defun assignment-op (op)
 979   (case op
 980     (+ '+=)
 981     (~ '~=)
 982     (\& '\&=)
 983     (\| '\|=)
 984     (- '-=)
 985     (* '*=)
 986     (% '%=)
 987     (>> '>>=)
 988     (^  '^=)
 989     (<< '<<=)
 990     (>>> '>>>=)
 991     (/   '/=)
 992     (t   nil)))
 993
 994 (defun make-js-test (lhs rhs)
 995   (if (and (typep rhs 'op-form)
 996            (member lhs (op-args rhs) :test #'js-equal))
 997       (let ((args-without (remove lhs (op-args rhs)
 998                                   :count 1 :test #'js-equal))
 999             (args-without-first (remove lhs (op-args rhs)
1000                                         :count 1 :end 1
1001                                         :test #'js-equal))
1002             (one (list (make-instance 'number-literal :value 1))))
1003         #+nil
1004         (format t "OPERATOR: ~S, ARGS-WITHOUT: ~S, ARGS-WITHOUT-FIRST ~S~%"
1005                 (operator rhs)
1006                 args-without
1007                 args-without-first)
1008         (cond ((and (js-equal args-without one)
1009                     (eql (operator rhs) '+))
1010                (make-instance 'one-op :pre-p nil :op "++"
1011                               :value lhs))
1012               ((and (js-equal args-without-first one)
1013                     (eql (operator rhs) '-))
1014                (make-instance 'one-op :pre-p nil :op "--"
1015                               :value lhs))
1016               ((and (assignment-op (operator rhs))
1017                     (member (operator rhs)
1018                             '(+ *)))
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 args-without))))
1024               ((and (assignment-op (operator rhs))
1025                     (js-equal (first (op-args rhs)) lhs))
1026                (make-instance 'op-form
1027                               :operator (assignment-op (operator rhs))
1028                               :args (list lhs (make-instance 'op-form
1029                                                              :operator (operator rhs)
1030                                                              :args (cdr (op-args rhs))))))
1031               (t (make-instance 'js-setf :lhs lhs :rhsides (list rhs)))))
1032       (make-instance 'js-setf :lhs lhs :rhsides (list rhs))))
1033
1034 (define-js-compiler-macro setf (&rest args)
1035   (let ((assignments (loop for (lhs rhs) on args by #'cddr
1036                            for rexpr = (js-compile-to-expression rhs)
1037                            for lexpr = (js-compile-to-expression lhs)
1038                            collect (make-js-test lexpr rexpr))))
1039     (if (= (length assignments) 1)
1040         (first assignments)
1041         (make-instance 'js-body :indent "" :stmts assignments))))
1042
1043 (defmethod js-to-strings ((setf js-setf) start-pos)
1044   (dwim-join (cons (js-to-strings (setf-lhs setf) start-pos)
1045                    (mapcar #'(lambda (x) (js-to-strings x start-pos)) (setf-rhsides setf)))
1046              (- 80 start-pos 2)
1047              :join-after " ="))
1048
1049 (defmethod expression-precedence ((setf js-setf))
1050   (gethash '= *op-precedence-hash*))
1051
1052 ;;; defvar
1053
1054 (defjsclass js-defvar (statement)
1055   ((names :initarg :names :accessor var-names)
1056    (value :initarg :value :accessor var-value)))
1057
1058 (define-js-compiler-macro defvar (name &optional value)
1059   (make-instance 'js-defvar :names (list (js-compile-to-symbol name))
1060                  :value (when value (js-compile-to-expression value))))
1061
1062 (defmethod js-to-statement-strings ((defvar js-defvar) start-pos)
1063   (dwim-join (nconc (mapcar #'(lambda (x) (list (symbol-to-js x))) (var-names defvar))
1064                     (when (var-value defvar)
1065                       (list (js-to-strings (var-value defvar) start-pos))))
1066              (- 80 start-pos 2)
1067              :join-after " ="
1068              :start "var " :end ";"))
1069
1070 ;;; let
1071
1072 (define-js-compiler-macro let (decls &rest body)
1073   (let ((single-defvar (make-instance 'js-defvar
1074                                       :names (mapcar #'js-compile-to-symbol
1075                                                      (remove-if-not #'atom decls))
1076                                       :value nil))
1077         (defvars (mapcar #'(lambda (decl)
1078                              (let ((name (first decl))
1079                                    (value (second decl)))
1080                              (make-instance 'js-defvar
1081                                             :names (list (js-compile-to-symbol name))
1082                                             :value (js-compile-to-expression value))))
1083                          (remove-if #'atom decls))))
1084     (make-instance 'js-sub-body
1085                    :indent "  "
1086                    :stmts (nconc (when (var-names single-defvar) (list single-defvar))
1087                                  defvars
1088                                  (mapcar #'js-compile-to-statement body)))))
1089
1090 ;;; iteration
1091
1092 (defjsclass js-for (statement)
1093   ((vars :initarg :vars :accessor for-vars)
1094    (steps :initarg :steps :accessor for-steps)
1095    (check :initarg :check :accessor for-check)
1096    (body :initarg :body :accessor for-body)))
1097
1098 (defun make-for-vars (decls)
1099   (loop for decl in decls
1100         for var = (if (atom decl) decl (first decl))
1101         for init = (if (atom decl) nil (second decl))
1102         collect (make-instance 'js-defvar :names (list (js-compile-to-symbol var))
1103                                :value (js-compile-to-expression init))))
1104
1105 (defun make-for-steps (decls)
1106   (loop for decl in decls
1107         when (= (length decl) 3)
1108         collect (js-compile-to-expression (third decl))))
1109
1110 (define-js-compiler-macro do (decls termination &rest body)
1111   (let ((vars (make-for-vars decls))
1112         (steps (make-for-steps decls))
1113         (check (js-compile-to-expression (list 'not (first termination))))
1114         (body (js-compile-to-body (cons 'progn body) :indent "  ")))
1115     (make-instance 'js-for
1116                    :vars vars
1117                    :steps steps
1118                    :check check
1119                    :body body)))
1120
1121 (defjsmacro dotimes (iter &rest body)
1122   (let ((var (first iter))
1123         (times (second iter)))
1124   `(do ((,var 0 (1+ ,var)))
1125        ((>= ,var ,times))
1126      ,@body)))
1127
1128 (defjsmacro dolist (i-array &rest body)
1129   (let ((var (first i-array))
1130         (array (second i-array))
1131         (arrvar (js-gensym "arr"))
1132         (idx (js-gensym "i")))
1133     `(let ((,arrvar ,array))
1134       (do ((,idx 0 (1+ ,idx)))
1135           ((>= ,idx (slot-value ,arrvar 'length)))
1136         (let ((,var (aref ,arrvar ,idx)))
1137           ,@body)))))
1138
1139 (defmethod js-to-statement-strings ((for js-for) start-pos)
1140   (let* ((init (dwim-join (mapcar #'(lambda (x)
1141                                       (dwim-join (list (list (symbol-to-js (first (var-names x))))
1142                                                        (js-to-strings (var-value x)
1143                                                                       (+ start-pos 2)))
1144                                                  (- 80 start-pos 2)
1145                                                  :join-after " ="))
1146                                   (for-vars for))
1147                           (- 80 start-pos 2)
1148                           :start "var " :join-after ","))
1149          (check (js-to-strings (for-check for) (+ start-pos 2)))
1150          (steps (dwim-join (mapcar #'(lambda (x var)
1151                                        (dwim-join
1152                                         (list (list (symbol-to-js (first (var-names var))))
1153                                               (js-to-strings x (- start-pos 2)))
1154                                         (- 80 start-pos 2)
1155                                         :join-after " ="))
1156                                    (for-steps for)
1157                                    (for-vars for))
1158                            (- 80 start-pos 2)
1159                            :join-after ","))
1160          (header (dwim-join (list init check steps)
1161                             (- 80 start-pos 2)
1162                             :start "for (" :end ") {"
1163                             :join-after ";"))
1164          (body (js-to-statement-strings (for-body for) (+ start-pos 2))))
1165     (nconc header body (list "}"))))
1166
1167 (defjsclass for-each (statement)
1168   ((name :initarg :name :accessor fe-name)
1169    (value :initarg :value :accessor fe-value)
1170    (body :initarg :body :accessor fe-body)))
1171
1172 (define-js-compiler-macro doeach (decl &rest body)
1173   (make-instance 'for-each :name (js-compile-to-symbol (first decl))
1174                  :value (js-compile-to-expression (second decl))
1175                  :body (js-compile-to-body (cons 'progn body) :indent "  ")))
1176
1177 (defmethod js-to-statement-strings ((fe for-each) start-pos)
1178   (let ((header (dwim-join (list (list (symbol-to-js (fe-name fe)))
1179                                  (list "in")
1180                                  (js-to-strings (fe-value fe) (+ start-pos 2)))
1181                            (- 80 start-pos 2)
1182                            :start "for (var "
1183                            :end ") {"))
1184         (body (js-to-statement-strings (fe-body fe) (+ start-pos 2))))
1185     (nconc header body (list "}"))))
1186
1187 (defjsclass js-while (statement)
1188   ((check :initarg :check :accessor while-check)
1189    (body :initarg :body :accessor while-body)))
1190
1191 (define-js-compiler-macro while (check &rest body)
1192   (make-instance 'js-while
1193                  :check (js-compile-to-expression check)
1194                  :body (js-compile-to-body (cons 'progn body) :indent "  ")))
1195
1196 (defmethod js-to-statement-strings ((while js-while) start-pos)
1197   (let ((header (dwim-join (list (js-to-strings (while-check while) (+ start-pos 2)))
1198                            (- 80 start-pos 2)
1199                            :start "while ("
1200                            :end ") {"))
1201         (body (js-to-statement-strings (while-body while) (+ start-pos 2))))
1202     (nconc header body (list "}"))))
1203
1204 ;;; with
1205
1206 (defjsclass js-with (statement)
1207   ((obj :initarg :obj :accessor with-obj)
1208    (body :initarg :body :accessor with-body)))
1209
1210 (define-js-compiler-macro with (statement &rest body)
1211   (make-instance 'js-with
1212                  :obj (js-compile-to-expression statement)
1213                  :body (js-compile-to-body (cons 'progn body) :indent "  ")))
1214
1215 (defmethod js-to-statement-strings ((with js-with) start-pos)
1216   (nconc (dwim-join (list (js-to-strings (with-obj with) (+ start-pos 2)))
1217                     (- 80 start-pos 2)
1218                     :start "with (" :end ") {")
1219          (js-to-statement-strings (with-body with) (+ start-pos 2))
1220          (list "}")))
1221
1222 ;;; case
1223
1224 (defjsclass js-switch (statement)
1225   ((value :initarg :value :accessor case-value)
1226    (clauses :initarg :clauses :accessor case-clauses)))
1227
1228 (define-js-compiler-macro switch (value &rest clauses)
1229   (let ((clauses (mapcar #'(lambda (clause)
1230                              (let ((val (first clause))
1231                                    (body (cdr clause)))
1232                                (list (if (eql val 'default)
1233                                          'default
1234                                          (js-compile-to-expression val))
1235                                      (js-compile-to-body (cons 'progn body) :indent "  "))))
1236                          clauses))
1237         (check (js-compile-to-expression value)))
1238     (make-instance 'js-switch :value check
1239                    :clauses clauses)))
1240
1241 (defmethod js-to-statement-strings ((case js-switch) start-pos)
1242   (let ((body    (mapcan #'(lambda (clause)
1243                      (let ((val (car clause))
1244                            (body (second clause)))
1245                        (dwim-join (list (if (eql val 'default)
1246                                             (list "")
1247                                             (js-to-strings val (+ start-pos 2)))
1248                                         (js-to-statement-strings body (+ start-pos 2)))
1249                                   (- 80 start-pos 2)
1250                                   :start (if (eql val 'default) "  default" "  case ")
1251                                   :white-space "   "
1252                                   :join-after ":"))) (case-clauses case))))
1253
1254     #+nil
1255     (format t "body: ~S~%" body)
1256     (nconc (dwim-join (list (js-to-strings (case-value case) (+ start-pos 2)))
1257                     (- 80 start-pos 2)
1258                     :start "switch (" :end ") {")
1259            body
1260            (list "}"))))
1261
1262 (defjsmacro case (value &rest clauses)
1263   (labels ((make-clause (val body more)
1264              (cond ((listp val)
1265                     (append (mapcar #'list (butlast val))
1266                             (make-clause (first (last val)) body more)))
1267                    ((member val '(t otherwise))
1268                     (make-clause 'default body more))
1269                    (more `((,val ,@body break)))
1270                    (t `((,val ,@body))))))
1271     `(switch ,value ,@(mapcon #'(lambda (x)
1272                                   (make-clause (car (first x))
1273                                                (cdr (first x))
1274                                                (rest x)))
1275                               clauses))))
1276
1277 ;;; throw catch
1278
1279 (defjsclass js-try (statement)
1280   ((body :initarg :body :accessor try-body)
1281    (catch :initarg :catch :accessor try-catch)
1282    (finally :initarg :finally :accessor try-finally)))
1283
1284 (define-js-compiler-macro try (body &rest clauses)
1285   (let ((body (js-compile-to-body body :indent "  "))
1286         (catch (cdr (assoc :catch clauses)))
1287         (finally (cdr (assoc :finally clauses))))
1288     (make-instance 'js-try
1289                    :body body
1290                    :catch (when catch (list (js-compile-to-symbol (caar catch))
1291                                             (js-compile-to-body (cons 'progn (cdr catch))
1292                                                                 :indent "  ")))
1293                    :finally (when finally (js-compile-to-body (cons 'progn finally)
1294                                                               :indent "  ")))))
1295
1296 (defmethod js-to-statement-strings ((try js-try) start-pos)
1297   (let* ((catch (try-catch try))
1298          (finally (try-finally try))
1299          (catch-list (when catch
1300                        (nconc
1301                         (dwim-join (list (list (symbol-to-js (first catch))))
1302                                    (- 80 start-pos 2)
1303                                    :start "} catch ("
1304                                    :end ") {")
1305                         (js-to-statement-strings (second catch) (+ start-pos 2)))))
1306          (finally-list (when finally
1307                          (nconc (list "} finally {")
1308                                 (js-to-statement-strings finally (+ start-pos 2))))))
1309     (nconc (list "try {")
1310            (js-to-statement-strings (try-body try) (+ start-pos 2))
1311            catch-list
1312            finally-list
1313            (list "}"))))
1314
1315 ;;; regex
1316
1317 (defjsclass regex (expression)
1318   (value))
1319
1320 (define-js-compiler-macro regex (regex)
1321   (make-instance 'regex :value (string regex)))
1322
1323 (defun first-slash-p (string)
1324   (and (> (length string) 0)
1325        (eq (char string 0) '#\/)))
1326
1327 (defmethod js-to-strings ((regex regex) start-pos)
1328    (declare (ignore start-pos))
1329    (let ((slash (if (first-slash-p (value regex)) nil "/")))
1330      (list (format nil (concatenate 'string slash "~A" slash) (value regex)))))
1331
1332 ;;; conditional compilation
1333
1334 (defjsclass cc-if ()
1335   ((test :initarg :test :accessor cc-if-test)
1336    (body :initarg :body :accessor cc-if-body)))
1337
1338 (defmethod js-to-statement-strings ((cc cc-if) start-pos)
1339   (nconc (list (format nil "/*@if ~A" (cc-if-test cc)))
1340          (mapcan #'(lambda (x) (js-to-strings x start-pos)) (cc-if-body cc))
1341          (list "@end @*/")))
1342
1343 (define-js-compiler-macro cc-if (test &rest body)
1344   (make-instance 'cc-if :test test
1345                  :body (mapcar #'js-compile body)))
1346
1347 ;;; compiler
1348
1349 (defun js-compile (form)
1350   (setf form (js-expand-form form))
1351   (cond ((stringp form)
1352          (make-instance 'string-literal :value form))
1353         ((characterp form)
1354          (make-instance 'string-literal :value (string form)))
1355         ((numberp form)
1356          (make-instance 'number-literal :value form))
1357         ((symbolp form)
1358          (let ((c-macro (js-get-compiler-macro form)))
1359            (if c-macro
1360                (funcall c-macro)
1361                (make-instance 'js-variable :value form))))
1362         ((and (consp form)
1363               (eql (first form) 'quote))
1364          (second form))
1365         ((consp form)
1366          (js-compile-list form))
1367         (t (error "Unknown atomar expression ~S" form))))
1368
1369 (defun js-compile-list (form)
1370   (let* ((name (car form))
1371          (args (cdr form))
1372          (js-form (js-get-compiler-macro name)))
1373     (cond (js-form
1374            (apply js-form args))
1375
1376           ((op-form-p form)
1377            (make-instance 'op-form
1378                           :operator (js-convert-op-name (js-compile-to-symbol (first form)))
1379                           :args (mapcar #'js-compile-to-expression (rest form))))
1380
1381           ((method-call-p form)
1382            (make-instance 'method-call
1383                           :method (js-compile-to-symbol (first form))
1384                           :object (js-compile-to-expression (second form))
1385                           :args (mapcar #'js-compile-to-expression (cddr form))))
1386
1387           ((funcall-form-p form)
1388            (make-instance 'function-call
1389                           :function (js-compile-to-expression (first form))
1390                           :args (mapcar #'js-compile-to-expression (rest form))))
1391
1392           (t (error "Unknown form ~S" form)))))
1393
1394 (defun js-compile-to-expression (form)
1395   (let ((res (js-compile form)))
1396     (assert (typep res 'expression))
1397     res))
1398
1399 (defun js-compile-to-symbol (form)
1400   (let ((res (js-compile form)))
1401     (when (typep res 'js-variable )
1402       (setf res (value res)))
1403     (assert (symbolp res))
1404     res))
1405
1406 (defun js-compile-to-statement (form)
1407   (let ((res (js-compile form)))
1408     (assert (typep res 'statement))
1409     res))
1410
1411 (defun js-compile-to-body (form &key (indent ""))
1412   (let ((res (js-compile-to-statement form)))
1413     (if (typep res 'js-body)
1414         (progn (setf (b-indent res) indent)
1415                res)
1416         (make-instance 'js-body
1417                        :indent indent
1418                        :stmts (list res)))))
1419
1420 ;;; Math library
1421
1422 (defjsmacro floor (expr)
1423   `(*Math.floor ,expr))
1424
1425 (defjsmacro random ()
1426   `(*Math.random))
1427
1428 ;;; helper macros
1429
1430 (define-js-compiler-macro js (&rest body)
1431   (make-instance 'string-literal
1432                  :value (string-join (js-to-statement-strings
1433                                       (js-compile (cons 'progn body)) 0) " ")))
1434
1435 (define-js-compiler-macro js-inline (&rest body)
1436   (make-instance 'string-literal
1437                  :value (concatenate
1438                          'string
1439                          "javascript:"
1440                          (string-join (js-to-statement-strings
1441                                        (js-compile (cons 'progn body)) 0) " "))))
1442
1443
1444 (defmacro js (&rest body)
1445   `(js* '(progn ,@body)))
1446
1447 (defmacro js* (&rest body)
1448   "Return the javascript string representing BODY.
1449
1450 Body is evaluated."
1451   `(string-join
1452     (js-to-statement-strings (js-compile (list 'progn ,@body)) 0)
1453     (string #\Newline)))
1454
1455 (defun js-to-string (expr)
1456   (string-join
1457    (js-to-statement-strings (js-compile expr) 0)
1458    (string #\Newline)))
1459
1460 (defun js-to-line (expr)
1461   (string-join
1462    (js-to-statement-strings (js-compile expr) 0) " "))
1463
1464 (defmacro js-file (&rest body)
1465   `(html
1466     (:princ
1467      (js ,@body))))
1468
1469 (defmacro js-script (&rest body)
1470   `((:script :type "text/javascript")
1471     (:princ (format nil "~%// <![CDATA[~%"))
1472     (:princ (js ,@body))
1473     (:princ (format nil "~%// ]]>~%"))))
1474
1475 (defmacro js-inline (&rest body)
1476   `(js-inline* '(progn ,@body)))
1477
1478 (defmacro js-inline* (&rest body)
1479   "Just like JS-INLINE except that BODY is evaluated before being
1480 converted to javascript."
1481   `(concatenate 'string "javascript:"
1482     (string-join (js-to-statement-strings (js-compile (list 'progn ,@body)) 0) " ")))
1483