src/js.lisp

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