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