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