src/js-translation.lisp

   1 (in-package :parenscript.javascript)
   2
   3 (defgeneric js-to-strings (expression start-pos)
   4   (:documentation "Transform an enscript-javascript expression to a string"))
   5
   6 (defgeneric js-to-statement-strings (code-fragment start-pos)
   7   (:documentation "Transform an enscript-javascript code fragment to a string"))
   8
   9 ;;; indenter
  10
  11 (defun special-append-to-last (form elt)
  12   (flet ((special-append (form elt)
  13            (let ((len (length form)))
  14              (if (and (> len 0)
  15                       (string= (char form (1- len)) elt))
  16                  form
  17                  (concatenate 'string form elt)))))
  18     (cond ((stringp form)
  19            (special-append form elt))
  20           ((consp form)
  21            (let ((last (last form)))
  22              (if (stringp (car last))
  23                  (rplaca last (special-append (car last) elt))
  24                  (append-to-last (car last) elt))
  25            form))
  26           (t (error "unsupported form ~S" form)))))
  27
  28 (defun dwim-join (value-string-lists max-length
  29                   &key (start "")
  30                        end
  31                        (join-before "")
  32                        join-after
  33                        (white-space (make-string (length start) :initial-element #\Space))
  34                        (separator " ")
  35                   (append-to-last #'append-to-last)
  36                   (collect t))
  37     #+nil
  38     (format t "value-string-lists: ~S~%" value-string-lists)
  39
  40     ;;; collect single value-string-lists until line full
  41
  42     (do* ((string-lists value-string-lists (cdr string-lists))
  43           (string-list (car string-lists) (car string-lists))
  44           (cur-elt start)
  45           (is-first t nil)
  46           (cur-empty t)
  47           (res nil))
  48          ((null string-lists)
  49           (unless cur-empty
  50             (push cur-elt res))
  51           (if (null res)
  52               (list (concatenate 'string start end))
  53               (progn
  54                 (when end
  55                   (setf (first res)
  56                         (funcall append-to-last (first res) end)))
  57                 (nreverse res))))
  58       #+nil
  59       (format t "string-list: ~S~%" string-list)
  60
  61       (when join-after
  62         (unless (null (cdr string-lists))
  63           (funcall append-to-last string-list join-after)))
  64
  65       (if (and collect (= (length string-list) 1))
  66           (progn
  67             #+nil
  68             (format t "cur-elt: ~S line-length ~D, max-length ~D, string: ~S~%"
  69                     cur-elt
  70                     (+ (length (first string-list))
  71                        (length cur-elt))
  72                     max-length
  73                     (first string-list))
  74             (if (or cur-empty
  75                     (< (+ (length (first string-list))
  76                           (length cur-elt)) max-length))
  77                 (setf cur-elt
  78                       (concatenate 'string cur-elt
  79                                    (if (or is-first (and cur-empty (string= join-before "")))
  80                                         "" (concatenate 'string separator join-before))
  81                                    (first string-list))
  82                       cur-empty nil)
  83                 (progn
  84                   (push cur-elt res)
  85                   (setf cur-elt (concatenate 'string white-space
  86                                              join-before (first string-list))
  87                         cur-empty nil))))
  88
  89           (progn
  90             (unless cur-empty
  91               (push cur-elt res)
  92               (setf cur-elt white-space
  93                     cur-empty t))
  94             (setf res (nconc (nreverse
  95                               (cons (concatenate 'string
  96                                                  cur-elt
  97                                                  (if (null res)
  98                                                      "" join-before)
  99                                                  (first string-list))
 100                                     (mapcar #'(lambda (x) (concatenate 'string white-space x))
 101                                             (cdr string-list))))
 102                              res))
 103             (setf cur-elt white-space cur-empty t)))))
 104
 105 (defmethod js-to-strings ((expression expression) start-pos)
 106   (declare (ignore start-pos))
 107   (list (princ-to-string (value expression))))
 108
 109 (defmethod js-to-statement-strings ((expression expression) start-pos)
 110   (js-to-strings expression start-pos))
 111
 112 (defmethod js-to-statement-strings ((statement statement) start-pos)
 113   (declare (ignore start-pos))
 114   (list (princ-to-string (value statement))))
 115
 116 (defmethod js-to-strings ((expression script-quote) start-pos)
 117   (declare (ignore start-pos))
 118   (list
 119    (if (null (value expression))
 120        "null"
 121        (case (value expression)
 122          (t (error "Cannot translated quoted value ~s to javascript" (value expression)))))))
 123
 124 ;;; array literals
 125
 126 (defmethod js-to-strings ((array array-literal) start-pos)
 127   (let ((value-string-lists
 128          (mapcar #'(lambda (x) (js-to-strings x (+ start-pos 2)))
 129                  (array-values array)))
 130         (max-length (- 80 start-pos 2)))
 131     (dwim-join value-string-lists max-length
 132                :start "[ " :end " ]"
 133                :join-after ",")))
 134
 135 (defmethod js-to-strings ((aref js-aref) start-pos)
 136   (dwim-join (cons (js-to-strings (aref-array aref) start-pos)
 137                    (mapcar #'(lambda (x) (dwim-join (list (js-to-strings x (+ start-pos 2)))
 138                                                     (- 80 start-pos 2)
 139                                                     :start "[" :end "]"))
 140                            (aref-index aref)))
 141              (- 80 start-pos 2) :separator ""
 142              :white-space "  "))
 143
 144 ;;; object literals (maps and hash-tables)
 145
 146 (defmethod js-to-strings ((obj object-literal) start-pos)
 147   (dwim-join
 148    (loop
 149     for (key . value) in (object-values obj)
 150     append (list
 151             (dwim-join (list (list (format nil "~A:" (js-translate-symbol key)))
 152                              (js-to-strings value (+ start-pos 2)))
 153                        (- 80 start-pos 2)
 154                        :start "" :end "" :join-after "")))
 155    (- 80 start-pos 2)
 156    :start "{ " :end " }"
 157    :join-after ","))
 158
 159 ;;; string literals
 160
 161 (defvar *js-quote-char* #\'
 162   "Specifies which character JS sholud use for delimiting strings.
 163
 164 This variable is usefull when have to embed some javascript code
 165 in an html attribute delimited by #\\\" as opposed to #\\', or
 166 vice-versa.")
 167
 168 (defparameter *js-lisp-escaped-chars*
 169   '((#\' . #\')
 170     (#\\ . #\\)
 171     (#\b . #\Backspace)
 172     (#\f . #.(code-char 12))
 173     (#\n . #\Newline)
 174     (#\r . #\Return)
 175     (#\t . #\Tab)))
 176
 177 (defun lisp-special-char-to-js (lisp-char)
 178     (car (rassoc lisp-char *js-lisp-escaped-chars*)))
 179
 180 (defmethod js-to-strings ((string string-literal) start-pos)
 181   (declare (ignore start-pos)
 182            (inline lisp-special-char-to-js))
 183   (list (with-output-to-string (escaped)
 184           (write-char *js-quote-char*  escaped)
 185           (loop
 186            for char across (value string)
 187            for code = (char-code char)
 188            for special = (lisp-special-char-to-js char)
 189            do
 190            (cond
 191              (special
 192               (write-char #\\ escaped)
 193               (write-char special escaped))
 194              ((or (<= code #x1f) (>= code #x80))
 195               (format escaped "\\u~4,'0x" code))
 196              (t (write-char char escaped)))
 197            finally (write-char *js-quote-char* escaped)))))
 198
 199 ;;; variables
 200 (defgeneric js-translate-symbol-contextually (symbol package env)
 201   (:documentation "Translates a symbol to a string in the given environment & package
 202 and for the given symbol."))
 203
 204 (defparameter *obfuscate-standard-identifiers* nil)
 205
 206 (defparameter *obfuscation-table* (make-hash-table))
 207
 208 (defun obfuscated-symbol (symbol)
 209   (or (gethash symbol *obfuscation-table*)
 210       (setf (gethash symbol *obfuscation-table*) (string (gensym)))))
 211
 212 (defmethod js-translate-symbol-contextually ((symbol symbol)
 213                                              (package ps::script-package)
 214                                              (env ps::compilation-environment))
 215   (cond
 216     ((member (ps::script-package-lisp-package package)
 217              (mapcar #'find-package '(:keyword :parenscript.global)))
 218      (symbol-to-js symbol))
 219     (*obfuscate-standard-identifiers*
 220      (obfuscated-symbol symbol))
 221     (t
 222      (case *package-prefix-style*
 223        (:prefix
 224 ;       (when (first
 225         (format nil "~A_~A"
 226                 (symbol-to-js (script-package-name package))
 227                 (symbol-to-js symbol)))
 228        (t
 229         (symbol-to-js (value symbol)))))))
 230
 231 (defgeneric js-translate-symbol (var)
 232   (:documentation "Given a JS-VARIABLE returns an output
 233 JavaScript version of it as a string."))
 234
 235 (defmethod js-translate-symbol ((var js-variable))
 236   (js-translate-symbol (value var)))
 237
 238 (defmethod js-translate-symbol ((var-name symbol))
 239   (if parenscript::*enable-package-system*
 240       (js-translate-symbol-contextually
 241        var-name
 242        (ps::symbol-script-package var-name)
 243        ps::*compilation-environment*)
 244       (symbol-to-js var-name)))
 245
 246 (defmethod js-to-strings ((v js-variable) start-form)
 247   (declare (ignore start-form))
 248   (list (js-translate-symbol v)))
 249
 250 ;;; arithmetic operators
 251 (defun script-convert-op-name (op)
 252   (case op
 253     (and '\&\&)
 254     (or '\|\|)
 255     (not '!)
 256     (eql '\=\=)
 257     (=   '\=\=)
 258     (t op)))
 259
 260 (defun op-form-p (form)
 261   (and (listp form)
 262        (not (script-special-form-p form))
 263        (not (null (op-precedence (first form))))))
 264
 265 (defun klammer (string-list)
 266   (prepend-to-first string-list "(")
 267   (append-to-last string-list ")")
 268   string-list)
 269
 270 (defmethod expression-precedence ((expression expression))
 271   0)
 272
 273 (defmethod expression-precedence ((form op-form))
 274   (op-precedence (operator form)))
 275
 276 (defmethod js-to-strings ((form op-form) start-pos)
 277   (let* ((precedence (expression-precedence form))
 278          (value-string-lists
 279           (mapcar #'(lambda (x)
 280                       (let ((string-list (js-to-strings x (+ start-pos 2))))
 281                         (if (>= (expression-precedence x) precedence)
 282                             (klammer string-list)
 283                             string-list)))
 284                   (op-args form)))
 285          (max-length (- 80 start-pos 2))
 286          (op-string (format nil "~A " (operator form))))
 287     (dwim-join value-string-lists max-length :join-before op-string)
 288     ))
 289
 290 (defmethod js-to-strings ((one-op one-op) start-pos)
 291   (let* ((value (value one-op))
 292          (value-strings (js-to-strings value start-pos)))
 293     (when (typep value 'op-form)
 294       (setf value-strings (klammer value-strings)))
 295     (if (one-op-pre-p one-op)
 296       (prepend-to-first value-strings
 297                         (one-op one-op))
 298       (append-to-last value-strings
 299                       (one-op one-op)))))
 300
 301 ;;; function calls
 302
 303 (defmethod js-to-strings ((form function-call) start-pos)
 304   (let* ((value-string-lists
 305           (mapcar #'(lambda (x) (js-to-strings x (+ start-pos 2)))
 306                   (f-args form)))
 307          (max-length (- 80 start-pos 2))
 308          (args (dwim-join value-string-lists max-length
 309                           :start "(" :end ")" :join-after ",")))
 310     (etypecase (f-function form)
 311       (js-lambda
 312        (dwim-join (list (append (dwim-join (list (js-to-strings (f-function form) (+ start-pos 2)))
 313                                            max-length
 314                                            :start "(" :end ")" :separator "")
 315                                 args))
 316                   max-length
 317                   :separator ""))
 318       ((or js-variable js-aref js-slot-value)
 319        (dwim-join (list (js-to-strings (f-function form) (+ start-pos 2))
 320                         args)
 321                   max-length
 322                   :separator ""))
 323       (function-call
 324        ;; TODO it adds superfluous newlines after each ()
 325        ;; and it's nearly the same as the js-lambda case above
 326        (dwim-join (list (append (dwim-join (list (js-to-strings (f-function form) (+ start-pos 2)))
 327                                            max-length :separator "")
 328                                 args))
 329                   max-length :separator "")))))
 330
 331 (defmethod js-to-strings ((form method-call) start-pos)
 332   (let ((object (js-to-strings (m-object form) (+ start-pos 2))))
 333     ;; TODO: this may not be the best way to add ()'s around lambdas
 334     ;; probably there is or should be a more general solution working
 335     ;; in other situations involving lambda's
 336     (when (member (m-object form) (list 'js-lambda 'number-literal 'js-object 'op-form)
 337                   :test #'typep)
 338       (push "(" object)
 339       (nconc object (list ")")))
 340     (let* ((fname (dwim-join (list object
 341                                    (list (js-translate-symbol (m-method form))))
 342                              (- 80 start-pos 2)
 343                              :end "("
 344                              :separator ""))
 345            (butlast (butlast fname))
 346            (last (car (last fname)))
 347            (method-and-args (dwim-join (mapcar #'(lambda (x) (js-to-strings x (+ start-pos 2)))
 348                                                (m-args form))
 349                                        (- 80 start-pos 2)
 350                                        :start last
 351                                        :end ")"
 352                                        :join-after ","))
 353            (ensure-no-newline-before-dot (concatenate 'string
 354                                                       (car (last butlast))
 355                                                       (first method-and-args))))
 356       (nconc (butlast butlast)
 357              (list ensure-no-newline-before-dot)
 358              (rest method-and-args)))))
 359
 360 ;;; optimization that gets rid of nested blocks, which have no meaningful effect
 361 ;;; in javascript
 362 (defgeneric expanded-subblocks (block)
 363   (:method (block)
 364     (list block))
 365   (:method ((block js-block))
 366     (mapcan #'expanded-subblocks (block-statements block))))
 367
 368 (defun consolidate-subblocks (block)
 369   (setf (block-statements block) (expanded-subblocks block))
 370   block)
 371
 372
 373 (defmethod js-to-statement-strings ((body js-block) start-pos)
 374   (consolidate-subblocks body)
 375   (dwim-join (mapcar #'(lambda (x) (js-to-statement-strings x (+ start-pos 2)))
 376                      (block-statements body))
 377              (- 80 start-pos 2)
 378              :join-after ";"
 379              :append-to-last #'special-append-to-last
 380              :start (block-indent body) :collect nil
 381              :end ";"))
 382
 383 (defmethod js-to-strings ((body js-block) start-pos)
 384   (dwim-join (mapcar #'(lambda (x) (js-to-strings x (+ start-pos 2)))
 385                      (block-statements body))
 386              (- 80 start-pos 2)
 387              :append-to-last #'special-append-to-last
 388              :join-after ","
 389              :start (block-indent body)))
 390
 391
 392 (defmethod js-to-statement-strings ((body js-sub-block) start-pos)
 393   (declare (ignore start-pos))
 394   (nconc (list "{") (call-next-method) (list "}")))
 395
 396 ;;; function definition
 397 (defmethod js-to-strings ((lambda js-lambda) start-pos)
 398   (let ((fun-header (dwim-join (mapcar #'(lambda (x)
 399                                            (list (js-translate-symbol x)))
 400                                        (lambda-args lambda))
 401                                (- 80 start-pos 2)
 402                                :start (function-start-string lambda)
 403                                :end ") {" :join-after ","))
 404         (fun-body (js-to-statement-strings (lambda-body lambda) (+ start-pos 2))))
 405     (nconc fun-header fun-body (list "}"))))
 406
 407 (defgeneric function-start-string (function)
 408   (:documentation "Returns the string that starts the function - this varies according to whether
 409 this is a lambda or a defun"))
 410
 411 (defmethod function-start-string ((lambda js-lambda))
 412   "function (")
 413
 414 (defmethod js-to-statement-strings ((lambda js-lambda) start-pos)
 415   (js-to-strings lambda start-pos))
 416
 417 (defmethod function-start-string ((defun js-defun))
 418   (format nil "function ~A(" (js-translate-symbol (defun-name defun))))
 419
 420 ;;; object creation
 421 (defmethod js-to-strings ((object js-object) start-pos)
 422   (let ((value-string-lists
 423          (mapcar #'(lambda (slot)
 424                      (let* ((slot-name (first slot))
 425                             (slot-string-name
 426                             (if (typep slot-name 'script-quote)
 427                                 (if (symbolp (value slot-name))
 428                                     (format nil "~A" (js-translate-symbol (value slot-name)))
 429                                     (format nil "~A" (first (js-to-strings slot-name 0))))
 430                                 (car (js-to-strings slot-name 0)))))
 431                        (dwim-join (list (js-to-strings (second slot) (+ start-pos 4)))
 432                                   (- 80 start-pos 2)
 433                                   :start (concatenate 'string slot-string-name  " : ")
 434                                   :white-space "    ")))
 435                  (o-slots object)))
 436         (max-length (- 80 start-pos 2)))
 437     (dwim-join value-string-lists max-length
 438                :start "{ "
 439                :end " }"
 440                :join-after ", "
 441                :white-space "  "
 442                :collect nil)))
 443
 444 (defmethod js-to-strings ((sv js-slot-value) start-pos)
 445   (append-to-last (if (typep (sv-object sv) 'js-variable)
 446                       (js-to-strings (sv-object sv) start-pos)
 447                       (list (format nil "~A" (js-to-strings (sv-object sv) start-pos))))
 448                   (if (typep (sv-slot sv) 'script-quote)
 449                       (if (symbolp (value (sv-slot sv)))
 450                           (format nil ".~A" (js-translate-symbol (value (sv-slot sv))))
 451                           (format nil ".~A" (first (js-to-strings (sv-slot sv) 0))))
 452                       (format nil "[~A]" (first (js-to-strings (sv-slot sv) 0))))))
 453
 454 ;;; cond
 455 (defmethod js-to-statement-strings ((cond js-cond) start-pos)
 456   (loop :for body :on (cond-bodies cond)
 457         :for first = (eq body (cond-bodies cond))
 458         :for last = (not (cdr body))
 459         :for test :in (cond-tests cond)
 460         :append (if (and last (not first) (string= (value test) "true"))
 461                     '("else {")
 462                     (dwim-join (list (js-to-strings test 0)) (- 80 start-pos 2)
 463                                :start (if first "if (" "else if (") :end ") {"))
 464         :append (js-to-statement-strings (car body) (+ start-pos 2))
 465         :collect "}"))
 466
 467 (defmethod js-to-statement-strings ((if js-if) start-pos)
 468   (let ((if-strings (dwim-join (list (js-to-strings (if-test if) 0))
 469                                (- 80 start-pos 2)
 470                                :start "if ("
 471                                :end ") {"))
 472         (then-strings (js-to-statement-strings (if-then if) (+ start-pos 2)))
 473         (else-strings (when (if-else if)
 474                         (js-to-statement-strings (if-else if)
 475                                                  (+ start-pos 2)))))
 476     (nconc if-strings then-strings (if else-strings
 477                                        (nconc (list "} else {") else-strings (list "}"))
 478                                        (list "}")))))
 479
 480 (defmethod js-to-strings ((if js-if) start-pos)
 481   (assert (typep (if-then if) 'expression))
 482   (when (if-else if)
 483     (assert (typep (if-else if) 'expression)))
 484   (dwim-join (list (append-to-last (js-to-strings (if-test if) start-pos) " ?")
 485                    (let* ((new-then (make-instance 'js-block
 486                                                    :statements (block-statements (if-then if))
 487                                                    :indent ""))
 488                           (res (js-to-strings new-then start-pos)))
 489                      (if (>= (expression-precedence (if-then if))
 490                              (expression-precedence if))
 491                              (klammer res)
 492                              res))
 493                    (list ":")
 494                    (if (if-else if)
 495                        (let* ((new-else (make-instance 'js-block
 496                                                        :statements (block-statements (if-else if))
 497                                                        :indent ""))
 498                               (res (js-to-strings new-else start-pos)))
 499                          (if (>= (expression-precedence (if-else if))
 500                                  (expression-precedence if))
 501                              (klammer res)
 502                              res))
 503                        (list "undefined")))
 504              (- 80 start-pos 2)
 505              :white-space "  "))
 506
 507 ;;; setf
 508 (defmethod js-to-strings ((setf js-setf) start-pos)
 509   (dwim-join (cons (js-to-strings (setf-lhs setf) start-pos)
 510                    (mapcar #'(lambda (x) (js-to-strings x start-pos)) (setf-rhsides setf)))
 511              (- 80 start-pos 2)
 512              :join-after " ="))
 513
 514 ;;; defvar
 515 (defmethod js-to-statement-strings ((defvar js-defvar) start-pos)
 516   (dwim-join (nconc (mapcar #'(lambda (x) (list (js-translate-symbol x))) (var-names defvar))
 517                     (when (var-value defvar)
 518                       (list (js-to-strings (var-value defvar) start-pos))))
 519              (- 80 start-pos 2)
 520              :join-after " ="
 521              :start "var " :end ";"))
 522
 523 ;;; iteration
 524 (defmethod js-to-statement-strings ((for js-for) start-pos)
 525   (let* ((init (dwim-join (mapcar #'(lambda (x)
 526                                       (dwim-join (list (list (js-translate-symbol (first (var-names x))))
 527                                                        (js-to-strings (var-value x)
 528                                                                       (+ start-pos 2)))
 529                                                  (- 80 start-pos 2)
 530                                                  :join-after " ="))
 531                                   (for-vars for))
 532                           (- 80 start-pos 2)
 533                           :start "var " :join-after ","))
 534          (check (js-to-strings (for-check for) (+ start-pos 2)))
 535          (steps (dwim-join (mapcar #'(lambda (x var)
 536                                        (dwim-join
 537                                         (list (list (js-translate-symbol (first (var-names var))))
 538                                               (js-to-strings x (- start-pos 2)))
 539                                         (- 80 start-pos 2)
 540                                         :join-after " ="))
 541                                    (for-steps for)
 542                                    (for-vars for))
 543                            (- 80 start-pos 2)
 544                            :join-after ","))
 545          (header (dwim-join (list init check steps)
 546                             (- 80 start-pos 2)
 547                             :start "for (" :end ") {"
 548                             :join-after ";"))
 549          (body (js-to-statement-strings (for-body for) (+ start-pos 2))))
 550     (nconc header body (list "}"))))
 551
 552
 553 (defmethod js-to-statement-strings ((fe for-each) start-pos)
 554   (let ((header (dwim-join (list (list (js-translate-symbol (fe-name fe)))
 555                                  (list "in")
 556                                  (js-to-strings (fe-value fe) (+ start-pos 2)))
 557                            (- 80 start-pos 2)
 558                            :start "for (var "
 559                            :end ") {"))
 560         (body (js-to-statement-strings (fe-body fe) (+ start-pos 2))))
 561     (nconc header body (list "}"))))
 562
 563 (defmethod js-to-statement-strings ((while js-while) start-pos)
 564   (let ((header (dwim-join (list (js-to-strings (while-check while) (+ start-pos 2)))
 565                            (- 80 start-pos 2)
 566                            :start "while ("
 567                            :end ") {"))
 568         (body (js-to-statement-strings (while-body while) (+ start-pos 2))))
 569     (nconc header body (list "}"))))
 570
 571 ;;; with
 572 (defmethod js-to-statement-strings ((with js-with) start-pos)
 573   (nconc (dwim-join (list (js-to-strings (with-obj with) (+ start-pos 2)))
 574                     (- 80 start-pos 2)
 575                     :start "with (" :end ") {")
 576          (js-to-statement-strings (with-body with) (+ start-pos 2))
 577          (list "}")))
 578
 579 ;;; switch
 580 (defmethod js-to-statement-strings ((case js-switch) start-pos)
 581   (let ((body    (mapcan #'(lambda (clause)
 582                      (let ((val (car clause))
 583                            (body (second clause)))
 584                        (dwim-join (list (if (eql val 'default)
 585                                             (list "")
 586                                             (js-to-strings val (+ start-pos 2)))
 587                                         (js-to-statement-strings body (+ start-pos 2)))
 588                                   (- 80 start-pos 2)
 589                                   :start (if (eql val 'default) "  default" "  case ")
 590                                   :white-space "   "
 591                                   :join-after ":"))) (case-clauses case))))
 592
 593     #+nil
 594     (format t "body: ~S~%" body)
 595     (nconc (dwim-join (list (js-to-strings (case-value case) (+ start-pos 2)))
 596                     (- 80 start-pos 2)
 597                     :start "switch (" :end ") {")
 598            body
 599            (list "}"))))
 600
 601 ;;; try-catch
 602 (defmethod js-to-statement-strings ((try js-try) start-pos)
 603   (let* ((catch (try-catch try))
 604          (finally (try-finally try))
 605          (catch-list (when catch
 606                        (nconc
 607                         (dwim-join (list (list (js-translate-symbol (first catch))))
 608                                    (- 80 start-pos 2)
 609                                    :start "} catch ("
 610                                    :end ") {")
 611                         (js-to-statement-strings (second catch) (+ start-pos 2)))))
 612          (finally-list (when finally
 613                          (nconc (list "} finally {")
 614                                 (js-to-statement-strings finally (+ start-pos 2))))))
 615     (nconc (list "try {")
 616            (js-to-statement-strings (try-body try) (+ start-pos 2))
 617            catch-list
 618            finally-list
 619            (list "}"))))
 620
 621 ;;; regex
 622 (defun first-slash-p (string)
 623   (and (> (length string) 0)
 624        (eq (char string 0) '#\/)))
 625
 626 (defmethod js-to-strings ((regex regex) start-pos)
 627    (declare (ignore start-pos))
 628    (let ((slash (if (first-slash-p (value regex)) nil "/")))
 629      (list (format nil (concatenate 'string slash "~A" slash) (value regex)))))
 630
 631 ;;; conditional compilation
 632 (defmethod js-to-statement-strings ((cc cc-if) start-pos)
 633   (nconc (list (format nil "/*@if ~A" (cc-if-test cc)))
 634          (mapcan #'(lambda (x) (js-to-strings x start-pos)) (cc-if-body cc))
 635          (list "@end @*/")))
 636
 637
 638 ;;; TODO instanceof
 639 (defmethod js-to-strings ((instanceof js-instanceof) start-pos)
 640   (dwim-join
 641    (list (js-to-strings (value instanceof) (+ start-pos 2))
 642          (list "instanceof")
 643          (js-to-strings (slot-value instanceof 'type) (+ start-pos 2)))
 644    (- 80 start-pos 2)
 645    :start "("
 646    :end ")"
 647    :white-space
 648    "  "))
 649
 650 ;;; single operations
 651 (defmacro define-translate-js-single-op (name &optional (superclass 'expression))
 652     (let ((script-name (intern (concatenate 'string "JS-" (symbol-name name)) #.*package*)))
 653       `(defmethod ,(if (eql superclass 'expression)
 654                        'js-to-strings
 655                        'js-to-statement-strings)
 656         ((,name ,script-name) start-pos)
 657         (dwim-join (list (js-to-strings (value ,name) (+ start-pos 2)))
 658          (- 80 start-pos 2)
 659          :start ,(concatenate 'string (string-downcase (symbol-name name)) " ")
 660          :white-space "  "))))
 661
 662 (define-translate-js-single-op return statement)
 663 (define-translate-js-single-op throw statement)
 664 (define-translate-js-single-op delete)
 665 (define-translate-js-single-op void)
 666 (define-translate-js-single-op typeof)
 667 (define-translate-js-single-op new)