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