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