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