[clinton/parenscript.git] / src / js-translation.lisp

(in-package :parenscript)

(defgeneric ps-print% (special-form-name special-form-args %start-pos%))

(defmacro defprinter (special-form content-args &body body)
  "Given a special-form name and a destructuring lambda-list for its
arguments, defines a printer for that form using the given body."
  (let ((sf (gensym))
        (sf-args (gensym)))
    `(defmethod ps-print% ((,sf (eql ',special-form)) ,sf-args %start-pos%)
      (declare (ignore ,sf))
      (destructuring-bind ,content-args
          ,sf-args
        ,@body))))

(defvar %start-pos%)

(defgeneric ps-print (compiled-form %start-pos%))

(defmethod ps-print ((compiled-form cons) %start-pos%)
  "Prints the given compiled ParenScript form starting at the given
indent position."
  (ps-print% (car compiled-form) (cdr compiled-form) %start-pos%))

;;; string literals
(defvar *js-quote-char* #\'
  "Specifies which character JS should use for delimiting strings.

This variable is useful when have to embed some javascript code
in an html attribute delimited by #\\\" as opposed to #\\', or
vice-versa.")

(defparameter *js-lisp-escaped-chars*
  '((#\' . #\')
    (#\\ . #\\)
    (#\b . #\Backspace)
    (#\f . #.(code-char 12))
    (#\n . #\Newline)
    (#\r . #\Return)
    (#\t . #\Tab)))

(defmethod ps-print ((string string) %start-pos%)
  (flet ((lisp-special-char-to-js (lisp-char)
           (car (rassoc lisp-char *js-lisp-escaped-chars*))))
    (list (with-output-to-string (escaped)
            (write-char *js-quote-char* escaped)
            (loop for char across string
                  for code = (char-code char)
                  for special = (lisp-special-char-to-js char)
                  do (cond
                       (special
                        (write-char #\\ escaped)
                        (write-char special escaped))
                       ((or (<= code #x1f) (>= code #x80))
                        (format escaped "\\u~4,'0x" code))
                       (t (write-char char escaped)))
                  finally (write-char *js-quote-char* escaped))))))

(defmethod ps-print ((number number) %start-pos%)
  (list (format nil (if (integerp number) "~S" "~F") number)))

;;; expression and operator precedence rules

(defun expression-precedence (expr)
  (if (consp expr)
      (case (car expr)
        (js-block (if (= (length (cdr expr)) 1)
                      (expression-precedence (first (cdr expr)))
                      (op-precedence 'comma)))
        (js-expression-if (op-precedence 'js-expression-if))
        (js-assign (op-precedence '=))
        (operator (op-precedence (second expr)))
        (otherwise 0))
      0))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defparameter *op-precedence-hash* (make-hash-table :test #'equal))

  ;;; generate the operator precedences from *OP-PRECEDENCES*
  (let ((precedence 1))
    (dolist (ops '((js-aref)
                   (js-slot-value)
                   (! not ~)
                   (* / %)
                   (+ -)
                   (<< >>)
                   (>>>)
                   (< > <= >=)
                   (in js-expression-if)
                   (eql == != =)
                   (=== !==)
                   (&)
                   (^)
                   (\|)
                   (\&\& and)
                   (\|\| or)
                   (js-assign *= /= %= += -= <<= >>= >>>= \&= ^= \|=)
                   (comma)))
      (dolist (op ops)
        (let ((op-name (symbol-name op)))
          (setf (gethash op-name *op-precedence-hash*) precedence)))
      (incf precedence)))

  (defun op-precedence (op)
    (gethash (if (symbolp op)
                 (symbol-name op)
                 op)
             *op-precedence-hash*)))

;;; indenter

(defmacro max-length () '(- 80 %start-pos% 2))

(defun ps-print-indent (ps-form)
  (ps-print ps-form (+ %start-pos% 2)))

(defun special-append-to-last (form elt)
  (flet ((special-append (form elt)
	   (let ((len (length form)))
	     (if (and (> len 0)
                      (string= (char form (1- len)) elt))
		 form
		 (concatenate 'string form elt)))))
    (cond ((stringp form)
	   (special-append form elt))
	  ((consp form)
	   (let ((last (last form)))
	     (if (stringp (car last))
		 (rplaca last (special-append (car last) elt))
		 (append-to-last (car last) elt))
	   form))
	  (t (error "Wrong argument type to indent appender: ~S" form)))))

(defun dwim-join (value-string-lists max-length
		  &key (start "")
                       end
		       (join-before "")
                       join-after
		       (white-space (make-string (length start) :initial-element #\Space))
                       (separator " ")
		  (append-to-last #'append-to-last)
		  (collect t))
    #+nil
    (format t "value-string-lists: ~S~%" value-string-lists)

    ;;; collect single value-string-lists until the line is full

    (do* ((string-lists value-string-lists (cdr string-lists))
	  (string-list (car string-lists) (car string-lists))
	  (cur-elt start)
          (is-first t nil)
	  (cur-empty t)
	  (res nil))
	 ((null string-lists)
	  (unless cur-empty
	    (push cur-elt res))
	  (if (null res)
	      (list (concatenate 'string start end))
	      (progn
		(when end
		  (setf (first res)
			(funcall append-to-last (first res) end)))
		(nreverse res))))
      #+nil
      (format t "string-list: ~S~%" string-list)

      (when join-after
	(unless (null (cdr string-lists))
	  (funcall append-to-last string-list join-after)))

      (if (and collect (= (length string-list) 1))
	  (progn
	    #+nil
	    (format t "cur-elt: ~S line-length ~D, max-length ~D, string: ~S~%"
		    cur-elt
		    (+ (length (first string-list))
		       (length cur-elt))
		    max-length
		    (first string-list))
	    (if (or cur-empty
		    (< (+ (length (first string-list))
			  (length cur-elt)) max-length))
		(setf cur-elt
		      (concatenate 'string cur-elt
				   (if (or is-first (and cur-empty (string= join-before "")))
                                        "" (concatenate 'string separator join-before))
				   (first string-list))
		      cur-empty nil)
		(progn
		  (push cur-elt res)
		  (setf cur-elt (concatenate 'string white-space
					     join-before (first string-list))
			cur-empty nil))))

	  (progn
	    (unless cur-empty
	      (push cur-elt res)
	      (setf cur-elt white-space
		    cur-empty t))
	    (setf res (nconc (nreverse
			      (cons (concatenate 'string
						 cur-elt
                                                 (if (null res)
						     "" join-before)
						 (first string-list))
				    (mapcar #'(lambda (x) (concatenate 'string white-space x))
					    (cdr string-list))))
                             res))
	    (setf cur-elt white-space cur-empty t)))))

(defprinter script-quote (val)
  (if (null val)
      (list "null")
      (error "Cannot translate quoted value ~S to javascript" val)))

(defprinter js-literal (str)
  (list str))

(defprinter js-keyword (str)
  (list str))

;;; array literals

(defprinter array-literal (&rest initial-contents)
  (let ((initial-contents-strings (mapcar #'ps-print-indent initial-contents)))
    (dwim-join initial-contents-strings (max-length)
	       :start "[ " :end " ]"
	       :join-after ",")))

(defprinter js-aref (array coords)
  (dwim-join (cons (ps-print array %start-pos%)
		   (mapcar (lambda (x) (dwim-join (list (ps-print-indent x))
                                                  (max-length)
                                                  :start "[" :end "]"))
			   coords))
	     (max-length)
             :white-space "  "
             :separator ""))

(defprinter object-literal (&rest arrows)
  (dwim-join (loop for (key . value) in arrows appending
                   (list (dwim-join (list (list (format nil "~A:" (js-translate-symbol key)))
                                          (ps-print-indent value))
                                    (max-length)
                                    :start "" :end "" :join-after "")))
             (max-length)
             :start "{ " :end " }"
             :join-after ","))

(defprinter js-variable (var)
  (list (js-translate-symbol var)))

;;; arithmetic operators
(defun script-convert-op-name (op)
  (case op
    (and '\&\&)
    (or '\|\|)
    (not '!)
    (eql '\=\=)
    (=   '\=\=)
    (t op)))

(defun parenthesize (string-list)
  (prepend-to-first string-list "(")
  (append-to-last string-list ")")
  string-list)

(defprinter operator (op args)
  (let* ((precedence (op-precedence op))
	 (arg-strings (mapcar (lambda (arg)
                                (let ((arg-strings (ps-print-indent arg)))
                                  (if (>= (expression-precedence arg) precedence)
                                      (parenthesize arg-strings)
                                      arg-strings)))
                              args))
	 (op-string (format nil "~A " op)))
    (dwim-join arg-strings (max-length) :join-before op-string)))

(defprinter unary-operator (op arg &key prefix)
  (let ((arg-string (ps-print arg %start-pos%)))
    (when (eql 'operator (car arg))
      (setf arg-string (parenthesize arg-string)))
    (if prefix
        (prepend-to-first arg-string op)
        (append-to-last arg-string op))))

;;; function and method calls
(defprinter js-funcall (fun-designator args)
  (let* ((arg-strings (mapcar #'ps-print-indent args))
	 (args (dwim-join arg-strings (max-length)
			  :start "(" :end ")" :join-after ",")))
    (cond ((eql 'js-lambda (car fun-designator))
           (dwim-join (list (append (dwim-join (list (ps-print-indent fun-designator))
                                               (max-length)
                                               :start "(" :end ")" :separator "")
                                    args))
                      (max-length)
                      :separator ""))
          ((member (car fun-designator) '(js-variable js-aref js-slot-value))
           (dwim-join (list (ps-print-indent fun-designator) args)
                      (max-length)
                      :separator ""))
          ((eql 'js-funcall (car fun-designator))
           ;; TODO it adds superfluous newlines after each ()
           ;; and it's nearly the same as the js-lambda case above
           (dwim-join (list (append (dwim-join (list (ps-print-indent fun-designator))
                                               (max-length) :separator "")
                                    args))
                      (max-length) :separator "")))))

(defprinter js-method-call (method object args)
  (let ((printed-object (ps-print object (+ %start-pos% 2))))
    ;; TODO: this may not be the best way to add ()'s around lambdas
    ;; probably there is or should be a more general solution working
    ;; in other situations involving lambda's
    (when (or (numberp object) (and (consp object) (member (car object) '(js-lambda js-object operator))))
      (setf printed-object (append (list "(") printed-object (list ")"))))
    (let* ((fname (dwim-join (list printed-object (list (js-translate-symbol method)))
                             (max-length)
                             :end "("
                             :separator ""))
           (butlast (butlast fname))
           (last (car (last fname)))
           (method-and-args (dwim-join (mapcar #'ps-print-indent args)
                                       (max-length)
                                       :start last
                                       :end ")"
                                       :join-after ","))
           (ensure-no-newline-before-dot (concatenate 'string
                                                      (car (last butlast))
                                                      (first method-and-args))))
      (append (butlast butlast) (list ensure-no-newline-before-dot) (cdr method-and-args)))))

(defprinter js-block (statement-p statements)
  (dwim-join (mapcar #'ps-print-indent statements)
	     (max-length)
	     :join-after (if statement-p ";" ",")
	     :append-to-last #'special-append-to-last
	     :start (if statement-p "    " "")
             :collect nil
	     :end (if statement-p ";" "")))

(defprinter js-lambda (args body)
  (print-fun-def nil args body %start-pos%))

(defprinter js-defun (name args body)
  (print-fun-def name args body %start-pos%))

(defun print-fun-def (name args body %start-pos%)
  (let ((fun-header (dwim-join (mapcar (lambda (x) (list (js-translate-symbol x)))
				       args)
			       (max-length)
			       :start (format nil "function ~:[~;~A~](" name (js-translate-symbol name))
                               :join-after ","
			       :end ") {"))
	(fun-body (ps-print-indent body)))
    (append fun-header fun-body (list "}"))))

;;; object creation
(defprinter js-object (slot-defs)
  (let ((value-string-lists (mapcar (lambda (slot)
                                      (let* ((slot-name (first slot))
                                             (slot-string-name
                                              (if (and (listp slot-name) (eql 'script-quote (car slot-name)))
                                                  (format nil "~A" (if (symbolp (second slot-name))
                                                                       (js-translate-symbol (second slot-name))
                                                                       (car (ps-print slot-name 0))))
                                                  (car (ps-print slot-name 0)))))
                                        (dwim-join (list (ps-print (second slot) (+ %start-pos% 4)))
                                                   (max-length)
                                                   :start (concatenate 'string slot-string-name  " : ")
                                                   :white-space "    ")))
                                    slot-defs)))
    (dwim-join value-string-lists (max-length)
	       :start "{ "
	       :end " }"
	       :join-after ", "
	       :white-space "  "
	       :collect nil)))

(defprinter js-slot-value (obj slot)
  (append-to-last (if (and (listp obj) (eql 'js-variable (car obj)))
                      (ps-print obj %start-pos%)
                      (list (format nil "~A" (ps-print obj %start-pos%))))
                  (if (and (listp slot) (eql 'script-quote (car slot)))
                      (format nil ".~A" (if (symbolp (second slot))
                                            (js-translate-symbol (second slot))
                                            (first (ps-print slot 0))))
                      (format nil "[~A]" (first (ps-print slot 0))))))

;;; cond
(defprinter js-cond (clauses)
  (loop for (test body-forms) in clauses
        for start = "if (" then "else if ("
        append (if (string= test "true")
                   '("else {")
                   (dwim-join (list (ps-print test 0)) (max-length)
                              :start start :end ") {"))
        append (mapcar #'ps-print-indent body-forms)
        collect "}"))

(defprinter js-statement-if (test then else)
  (let ((if-strings (dwim-join (list (ps-print test 0))
			       (- 80 %start-pos% 2)
			       :start "if ("
			       :end ") {"))
	(then-strings (ps-print-indent then))
	(else-strings (when else
			(ps-print-indent else))))
    (append if-strings then-strings (if else-strings
                                        (append (list "} else {") else-strings (list "}"))
                                        (list "}")))))

(defprinter js-expression-if (test then else)
  (dwim-join (list (append-to-last (ps-print test %start-pos%) " ?")
		   (let ((then-string (ps-print then %start-pos%)))
		     (if (>= (expression-precedence then) (op-precedence 'js-expression-if))
                         (parenthesize then-string)
                         then-string))
		   (list ":")
		   (if else
		       (let ((else-string (ps-print else %start-pos%)))
			 (if (>= (expression-precedence else) (op-precedence 'js-expression-if))
			     (parenthesize else-string)
			     else-string))
		       (list "undefined")))
	     (max-length)
	     :white-space "  "))

(defprinter js-assign (lhs rhs)
  (dwim-join (list (ps-print lhs %start-pos%) (ps-print rhs %start-pos%))
	     (max-length)
	     :join-after " ="))

(defprinter js-defvar (var-name &rest var-value)
  (dwim-join (append (list (list (js-translate-symbol var-name)))
                     (when var-value
                       (list (ps-print (car var-value) %start-pos%))))
	     (max-length)
	     :join-after " ="
	     :start "var " :end ";"))

;;; iteration
(defprinter js-for (vars steps test body-block)
  (let* ((init (dwim-join (mapcar (lambda (var-form)
                                    (dwim-join (list (list (js-translate-symbol (car var-form)))
                                                     (ps-print-indent (cdr var-form)))
                                               (max-length)
                                               :join-after " ="))
				  vars)
			  (max-length)
			  :start "var " :join-after ","))
	 (test-string (ps-print-indent test))
	 (step-strings (dwim-join (mapcar (lambda (x var-form)
                                            (dwim-join
                                             (list (list (js-translate-symbol (car var-form)))
                                                   (ps-print x (- %start-pos% 2)))
                                             (max-length)
                                             :join-after " ="))
                                          steps
                                          vars)
                                  (max-length)
                                  :join-after ","))
	 (header (dwim-join (list init test-string step-strings)
			    (max-length)
			    :start "for (" :end ") {"
			    :join-after ";"))
	 (body (ps-print-indent body-block)))
    (append header body (list "}"))))

(defprinter js-for-each (var object body-block)
  (let ((header (dwim-join (list (list (js-translate-symbol var))
				 (list "in")
				 (ps-print-indent object))
			   (max-length)
			   :start "for (var "
			   :end ") {"))
	(body (ps-print-indent body-block)))
    (append header body (list "}"))))

(defprinter js-while (test body-block)
  (let ((header-strings (dwim-join (list (ps-print-indent test))
			   (max-length)
			   :start "while ("
			   :end ") {"))
	(body-strings (ps-print-indent body-block)))
    (append header-strings body-strings (list "}"))))

(defprinter js-with (expression body-block)
  (append (dwim-join (list (ps-print-indent expression))
                     (max-length)
                     :start "with (" :end ") {")
          (ps-print-indent body-block)
          (list "}")))

(defprinter js-switch (test clauses)
  (let ((body-strings (mapcar (lambda (clause)
                                (let ((val (first clause))
                                      (body-block (second clause)))
                                  (dwim-join (list (if (eql val 'default)
                                                       (list "")
                                                       (ps-print-indent val))
                                                   (ps-print-indent body-block))
                                             (max-length)
                                             :start (if (eql val 'default) "  default" "  case ")
                                             :white-space "   "
                                             :join-after ":")))
                              clauses)))
    (append (dwim-join (list (ps-print-indent test))
                       (max-length)
                       :start "switch (" :end ") {")
            (reduce #'append body-strings)
            (list "}"))))

(defprinter js-try (body &key catch finally)
  (let ((catch-strings (when catch
                      (append (dwim-join (list (list (js-translate-symbol (first catch))))
                                         (max-length)
                                         :start "} catch ("
                                         :end ") {")
                              (ps-print-indent (second catch)))))
        (finally-strings (when finally
                           (append (list "} finally {")
                                   (ps-print-indent finally)))))
    (append (list "try {")
            (ps-print-indent body)
            catch-strings
            finally-strings
            (list "}"))))

;;; regex
(defprinter js-regex (regex)
  (flet ((first-slash-p (string)
           (and (> (length string) 0) (eql (char string 0) '#\/))))
    (let ((slash (unless (first-slash-p regex) "/")))
      (list (format nil (concatenate 'string slash "~A" slash) regex)))))

(defprinter js-return (value)
  (let ((printed-value (ps-print value 0)))
    (cons (concatenate 'string "return " (car printed-value)) (cdr printed-value))))

;;; conditional compilation
(defprinter cc-if (test body-forms)
  (append (list (format nil "/*@if ~A" test))
          (mapcar (lambda (x) (ps-print x %start-pos%)) body-forms)
          (list "@end @*/")))

;;; TODO instanceof
(defprinter js-instanceof (value type)
  (dwim-join (list (ps-print-indent value)
                   (list "instanceof")
                   (ps-print-indent type))
             (max-length)
             :start "("
             :end ")"
             :white-space "  "))

(defprinter js-named-operator (op value)
  (dwim-join (list (ps-print-indent value))
             (max-length)
             :start (concatenate 'string (string-downcase (symbol-name op)) " ")
             :white-space "  "))
Commit	Line	Data
4a987e2b	1	(in-package :parenscript)
9da682ca	2
4a987e2b	3	(defgeneric ps-print% (special-form-name special-form-args %start-pos%))
9da682ca	4
4a987e2b VS	5	(defmacro defprinter (special-form content-args &body body)
	6	"Given a special-form name and a destructuring lambda-list for its
	7	arguments, defines a printer for that form using the given body."
	8	(let ((sf (gensym))
	9	(sf-args (gensym)))
	10	`(defmethod ps-print% ((,sf (eql ',special-form)) ,sf-args %start-pos%)
	11	(declare (ignore ,sf))
	12	(destructuring-bind ,content-args
	13	,sf-args
	14	,@body))))
	15
	16	(defvar %start-pos%)
	17
	18	(defgeneric ps-print (compiled-form %start-pos%))
	19
	20	(defmethod ps-print ((compiled-form cons) %start-pos%)
	21	"Prints the given compiled ParenScript form starting at the given
	22	indent position."
	23	(ps-print% (car compiled-form) (cdr compiled-form) %start-pos%))
	24
	25	;;; string literals
	26	(defvar js-quote-char #\'
	27	"Specifies which character JS should use for delimiting strings.
	28
	29	This variable is useful when have to embed some javascript code
	30	in an html attribute delimited by #\\\" as opposed to #\\', or
	31	vice-versa.")
	32
	33	(defparameter js-lisp-escaped-chars
	34	'((#\' . #\')
	35	(#\\ . #\\)
	36	(#\b . #\Backspace)
	37	(#\f . #.(code-char 12))
	38	(#\n . #\Newline)
	39	(#\r . #\Return)
	40	(#\t . #\Tab)))
	41
	42	(defmethod ps-print ((string string) %start-pos%)
	43	(flet ((lisp-special-char-to-js (lisp-char)
	44	(car (rassoc lisp-char js-lisp-escaped-chars))))
	45	(list (with-output-to-string (escaped)
	46	(write-char js-quote-char escaped)
	47	(loop for char across string
	48	for code = (char-code char)
	49	for special = (lisp-special-char-to-js char)
	50	do (cond
	51	(special
	52	(write-char #\\ escaped)
	53	(write-char special escaped))
	54	((or (<= code #x1f) (>= code #x80))
	55	(format escaped "\\u~4,'0x" code))
	56	(t (write-char char escaped)))
	57	finally (write-char js-quote-char escaped))))))
	58
	59	(defmethod ps-print ((number number) %start-pos%)
	60	(list (format nil (if (integerp number) "~S" "~F") number)))
	61
	62	;;; expression and operator precedence rules
	63
	64	(defun expression-precedence (expr)
	65	(if (consp expr)
	66	(case (car expr)
	67	(js-block (if (= (length (cdr expr)) 1)
	68	(expression-precedence (first (cdr expr)))
69	(op-precedence 'comma)))
70	(js-expression-if (op-precedence 'js-expression-if))
71	(js-assign (op-precedence '=))
72	(operator (op-precedence (second expr)))
73	(otherwise 0))
74	0))
75
76	(eval-when (:compile-toplevel :load-toplevel :execute)
77	(defparameter op-precedence-hash (make-hash-table :test #'equal))
78
79	;;; generate the operator precedences from OP-PRECEDENCES
80	(let ((precedence 1))
81	(dolist (ops '((js-aref)
82	(js-slot-value)
83	(! not ~)
84	(* / %)
85	(+ -)
86	(<< >>)
87	(>>>)
88	(< > <= >=)
89	(in js-expression-if)
90	(eql == != =)
91	(=== !==)
92	(&)
93	(^)
94	(\\|)
95	(\&\& and)
96	(\\|\\| or)
97	(js-assign *= /= %= += -= <<= >>= >>>= \&= ^= \\|=)
98	(comma)))
99	(dolist (op ops)
100	(let ((op-name (symbol-name op)))
101	(setf (gethash op-name op-precedence-hash) precedence)))
102	(incf precedence)))
103
104	(defun op-precedence (op)
105	(gethash (if (symbolp op)
106	(symbol-name op)
107	op)
108	op-precedence-hash)))
9da682ca	109
cc4f1551 RD	110	;;; indenter
cc4f1551 RD	111
4a987e2b VS	112	(defmacro max-length () '(- 80 %start-pos% 2))
	113
	114	(defun ps-print-indent (ps-form)
	115	(ps-print ps-form (+ %start-pos% 2)))
	116
cc4f1551 RD	117	(defun special-append-to-last (form elt)
	118	(flet ((special-append (form elt)
	119	(let ((len (length form)))
	120	(if (and (> len 0)
	121	(string= (char form (1- len)) elt))
	122	form
	123	(concatenate 'string form elt)))))
	124	(cond ((stringp form)
	125	(special-append form elt))
	126	((consp form)
	127	(let ((last (last form)))
	128	(if (stringp (car last))
	129	(rplaca last (special-append (car last) elt))
	130	(append-to-last (car last) elt))
	131	form))
4a987e2b	132	(t (error "Wrong argument type to indent appender: ~S" form)))))
cc4f1551 RD	133
	134	(defun dwim-join (value-string-lists max-length
	135	&key (start "")
	136	end
	137	(join-before "")
	138	join-after
	139	(white-space (make-string (length start) :initial-element #\Space))
	140	(separator " ")
	141	(append-to-last #'append-to-last)
	142	(collect t))
	143	#+nil
	144	(format t "value-string-lists: ~S~%" value-string-lists)
	145
4a987e2b	146	;;; collect single value-string-lists until the line is full
cc4f1551 RD	147
	148	(do* ((string-lists value-string-lists (cdr string-lists))
	149	(string-list (car string-lists) (car string-lists))
	150	(cur-elt start)
	151	(is-first t nil)
	152	(cur-empty t)
	153	(res nil))
	154	((null string-lists)
	155	(unless cur-empty
	156	(push cur-elt res))
	157	(if (null res)
	158	(list (concatenate 'string start end))
	159	(progn
	160	(when end
	161	(setf (first res)
	162	(funcall append-to-last (first res) end)))
	163	(nreverse res))))
	164	#+nil
	165	(format t "string-list: ~S~%" string-list)
	166
	167	(when join-after
	168	(unless (null (cdr string-lists))
	169	(funcall append-to-last string-list join-after)))
	170
	171	(if (and collect (= (length string-list) 1))
	172	(progn
	173	#+nil
	174	(format t "cur-elt: ~S line-length ~D, max-length ~D, string: ~S~%"
	175	cur-elt
	176	(+ (length (first string-list))
	177	(length cur-elt))
	178	max-length
	179	(first string-list))
	180	(if (or cur-empty
	181	(< (+ (length (first string-list))
	182	(length cur-elt)) max-length))
	183	(setf cur-elt
	184	(concatenate 'string cur-elt
	185	(if (or is-first (and cur-empty (string= join-before "")))
	186	"" (concatenate 'string separator join-before))
	187	(first string-list))
	188	cur-empty nil)
	189	(progn
	190	(push cur-elt res)
	191	(setf cur-elt (concatenate 'string white-space
	192	join-before (first string-list))
	193	cur-empty nil))))
	194
	195	(progn
	196	(unless cur-empty
	197	(push cur-elt res)
	198	(setf cur-elt white-space
	199	cur-empty t))
	200	(setf res (nconc (nreverse
	201	(cons (concatenate 'string
	202	cur-elt
	203	(if (null res)
	204	"" join-before)
	205	(first string-list))
	206	(mapcar #'(lambda (x) (concatenate 'string white-space x))
	207	(cdr string-list))))
	208	res))
	209	(setf cur-elt white-space cur-empty t)))))
	210
4a987e2b VS	211	(defprinter script-quote (val)
	212	(if (null val)
	213	(list "null")
	214	(error "Cannot translate quoted value ~S to javascript" val)))
cc4f1551	215
4a987e2b VS	216	(defprinter js-literal (str)
4a987e2b VS	217	(list str))
cc4f1551	218
4a987e2b VS	219	(defprinter js-keyword (str)
4a987e2b VS	220	(list str))
46f794a4	221
cc4f1551 RD	222	;;; array literals
cc4f1551 RD	223
4a987e2b VS	224	(defprinter array-literal (&rest initial-contents)
	225	(let ((initial-contents-strings (mapcar #'ps-print-indent initial-contents)))
	226	(dwim-join initial-contents-strings (max-length)
cc4f1551 RD	227	:start "[ " :end " ]"
	228	:join-after ",")))
	229
4a987e2b VS	230	(defprinter js-aref (array coords)
	231	(dwim-join (cons (ps-print array %start-pos%)
	232	(mapcar (lambda (x) (dwim-join (list (ps-print-indent x))
	233	(max-length)
	234	:start "[" :end "]"))
	235	coords))
	236	(max-length)
	237	:white-space " "
	238	:separator ""))
	239
	240	(defprinter object-literal (&rest arrows)
	241	(dwim-join (loop for (key . value) in arrows appending
	242	(list (dwim-join (list (list (format nil "~A:" (js-translate-symbol key)))
	243	(ps-print-indent value))
	244	(max-length)
	245	:start "" :end "" :join-after "")))
	246	(max-length)
	247	:start "{ " :end " }"
	248	:join-after ","))
	249
	250	(defprinter js-variable (var)
	251	(list (js-translate-symbol var)))
cc4f1551 RD	252
cc4f1551 RD	253	;;; arithmetic operators
9da682ca	254	(defun script-convert-op-name (op)
cc4f1551 RD	255	(case op
	256	(and '\&\&)
	257	(or '\\|\\|)
	258	(not '!)
	259	(eql '\=\=)
	260	(= '\=\=)
	261	(t op)))
	262
4a987e2b	263	(defun parenthesize (string-list)
cc4f1551 RD	264	(prepend-to-first string-list "(")
	265	(append-to-last string-list ")")
	266	string-list)
	267
4a987e2b VS	268	(defprinter operator (op args)
	269	(let* ((precedence (op-precedence op))
	270	(arg-strings (mapcar (lambda (arg)
	271	(let ((arg-strings (ps-print-indent arg)))
	272	(if (>= (expression-precedence arg) precedence)
	273	(parenthesize arg-strings)
	274	arg-strings)))
	275	args))
	276	(op-string (format nil "~A " op)))
	277	(dwim-join arg-strings (max-length) :join-before op-string)))
	278
	279	(defprinter unary-operator (op arg &key prefix)
	280	(let ((arg-string (ps-print arg %start-pos%)))
	281	(when (eql 'operator (car arg))
	282	(setf arg-string (parenthesize arg-string)))
	283	(if prefix
	284	(prepend-to-first arg-string op)
	285	(append-to-last arg-string op))))
	286
	287	;;; function and method calls
	288	(defprinter js-funcall (fun-designator args)
	289	(let* ((arg-strings (mapcar #'ps-print-indent args))
	290	(args (dwim-join arg-strings (max-length)
cc4f1551	291	:start "(" :end ")" :join-after ",")))
4a987e2b VS	292	(cond ((eql 'js-lambda (car fun-designator))
	293	(dwim-join (list (append (dwim-join (list (ps-print-indent fun-designator))
	294	(max-length)
	295	:start "(" :end ")" :separator "")
	296	args))
	297	(max-length)
	298	:separator ""))
	299	((member (car fun-designator) '(js-variable js-aref js-slot-value))
	300	(dwim-join (list (ps-print-indent fun-designator) args)
	301	(max-length)
	302	:separator ""))
	303	((eql 'js-funcall (car fun-designator))
	304	;; TODO it adds superfluous newlines after each ()
	305	;; and it's nearly the same as the js-lambda case above
	306	(dwim-join (list (append (dwim-join (list (ps-print-indent fun-designator))
	307	(max-length) :separator "")
	308	args))
	309	(max-length) :separator "")))))
	310
	311	(defprinter js-method-call (method object args)
	312	(let ((printed-object (ps-print object (+ %start-pos% 2))))
cc4f1551 RD	313	;; TODO: this may not be the best way to add ()'s around lambdas
	314	;; probably there is or should be a more general solution working
	315	;; in other situations involving lambda's
4a987e2b VS	316	(when (or (numberp object) (and (consp object) (member (car object) '(js-lambda js-object operator))))
	317	(setf printed-object (append (list "(") printed-object (list ")"))))
	318	(let* ((fname (dwim-join (list printed-object (list (js-translate-symbol method)))
	319	(max-length)
cc4f1551 RD	320	:end "("
	321	:separator ""))
	322	(butlast (butlast fname))
	323	(last (car (last fname)))
4a987e2b VS	324	(method-and-args (dwim-join (mapcar #'ps-print-indent args)
4a987e2b VS	325	(max-length)
cc4f1551 RD	326	:start last
	327	:end ")"
	328	:join-after ","))
	329	(ensure-no-newline-before-dot (concatenate 'string
	330	(car (last butlast))
	331	(first method-and-args))))
4a987e2b	332	(append (butlast butlast) (list ensure-no-newline-before-dot) (cdr method-and-args)))))
cc4f1551	333
4a987e2b VS	334	(defprinter js-block (statement-p statements)
	335	(dwim-join (mapcar #'ps-print-indent statements)
	336	(max-length)
	337	:join-after (if statement-p ";" ",")
cc4f1551	338	:append-to-last #'special-append-to-last
4a987e2b VS	339	:start (if statement-p " " "")
	340	:collect nil
	341	:end (if statement-p ";" "")))
	342
	343	(defprinter js-lambda (args body)
	344	(print-fun-def nil args body %start-pos%))
	345
	346	(defprinter js-defun (name args body)
	347	(print-fun-def name args body %start-pos%))
	348
	349	(defun print-fun-def (name args body %start-pos%)
	350	(let ((fun-header (dwim-join (mapcar (lambda (x) (list (js-translate-symbol x)))
	351	args)
	352	(max-length)
	353	:start (format nil "function ~:[~;~A~](" name (js-translate-symbol name))
	354	:join-after ","
	355	:end ") {"))
	356	(fun-body (ps-print-indent body)))
	357	(append fun-header fun-body (list "}"))))
cc4f1551 RD	358
cc4f1551 RD	359	;;; object creation
4a987e2b VS	360	(defprinter js-object (slot-defs)
	361	(let ((value-string-lists (mapcar (lambda (slot)
	362	(let* ((slot-name (first slot))
	363	(slot-string-name
	364	(if (and (listp slot-name) (eql 'script-quote (car slot-name)))
	365	(format nil "~A" (if (symbolp (second slot-name))
	366	(js-translate-symbol (second slot-name))
	367	(car (ps-print slot-name 0))))
	368	(car (ps-print slot-name 0)))))
	369	(dwim-join (list (ps-print (second slot) (+ %start-pos% 4)))
	370	(max-length)
	371	:start (concatenate 'string slot-string-name " : ")
	372	:white-space " ")))
	373	slot-defs)))
	374	(dwim-join value-string-lists (max-length)
cc4f1551 RD	375	:start "{ "
	376	:end " }"
	377	:join-after ", "
	378	:white-space " "
	379	:collect nil)))
	380
4a987e2b	381	(defprinter js-slot-value (obj slot)
a805b30d	382	(append-to-last (if (and (listp obj) (eql 'js-variable (car obj)))
4a987e2b VS	383	(ps-print obj %start-pos%)
4a987e2b VS	384	(list (format nil "~A" (ps-print obj %start-pos%))))
a805b30d	385	(if (and (listp slot) (eql 'script-quote (car slot)))
4a987e2b VS	386	(format nil ".~A" (if (symbolp (second slot))
	387	(js-translate-symbol (second slot))
	388	(first (ps-print slot 0))))
	389	(format nil "[~A]" (first (ps-print slot 0))))))
cc4f1551 RD	390
cc4f1551 RD	391	;;; cond
4a987e2b VS	392	(defprinter js-cond (clauses)
	393	(loop for (test body-forms) in clauses
	394	for start = "if (" then "else if ("
	395	append (if (string= test "true")
	396	'("else {")
	397	(dwim-join (list (ps-print test 0)) (max-length)
	398	:start start :end ") {"))
	399	append (mapcar #'ps-print-indent body-forms)
	400	collect "}"))
	401
	402	(defprinter js-statement-if (test then else)
	403	(let ((if-strings (dwim-join (list (ps-print test 0))
	404	(- 80 %start-pos% 2)
cc4f1551 RD	405	:start "if ("
cc4f1551 RD	406	:end ") {"))
4a987e2b VS	407	(then-strings (ps-print-indent then))
	408	(else-strings (when else
	409	(ps-print-indent else))))
	410	(append if-strings then-strings (if else-strings
	411	(append (list "} else {") else-strings (list "}"))
	412	(list "}")))))
	413
	414	(defprinter js-expression-if (test then else)
	415	(dwim-join (list (append-to-last (ps-print test %start-pos%) " ?")
	416	(let ((then-string (ps-print then %start-pos%)))
	417	(if (>= (expression-precedence then) (op-precedence 'js-expression-if))
	418	(parenthesize then-string)
	419	then-string))
cc4f1551	420	(list ":")
4a987e2b VS	421	(if else
	422	(let ((else-string (ps-print else %start-pos%)))
	423	(if (>= (expression-precedence else) (op-precedence 'js-expression-if))
	424	(parenthesize else-string)
	425	else-string))
cc4f1551	426	(list "undefined")))
4a987e2b	427	(max-length)
cc4f1551 RD	428	:white-space " "))
cc4f1551 RD	429
4a987e2b VS	430	(defprinter js-assign (lhs rhs)
	431	(dwim-join (list (ps-print lhs %start-pos%) (ps-print rhs %start-pos%))
	432	(max-length)
cc4f1551 RD	433	:join-after " ="))
cc4f1551 RD	434
4a987e2b VS	435	(defprinter js-defvar (var-name &rest var-value)
	436	(dwim-join (append (list (list (js-translate-symbol var-name)))
	437	(when var-value
	438	(list (ps-print (car var-value) %start-pos%))))
	439	(max-length)
cc4f1551 RD	440	:join-after " ="
	441	:start "var " :end ";"))
	442
	443	;;; iteration
4a987e2b VS	444	(defprinter js-for (vars steps test body-block)
	445	(let* ((init (dwim-join (mapcar (lambda (var-form)
	446	(dwim-join (list (list (js-translate-symbol (car var-form)))
	447	(ps-print-indent (cdr var-form)))
	448	(max-length)
	449	:join-after " ="))
	450	vars)
	451	(max-length)
cc4f1551	452	:start "var " :join-after ","))
4a987e2b VS	453	(test-string (ps-print-indent test))
	454	(step-strings (dwim-join (mapcar (lambda (x var-form)
	455	(dwim-join
	456	(list (list (js-translate-symbol (car var-form)))
	457	(ps-print x (- %start-pos% 2)))
	458	(max-length)
	459	:join-after " ="))
	460	steps
	461	vars)
	462	(max-length)
	463	:join-after ","))
	464	(header (dwim-join (list init test-string step-strings)
	465	(max-length)
cc4f1551 RD	466	:start "for (" :end ") {"
cc4f1551 RD	467	:join-after ";"))
4a987e2b VS	468	(body (ps-print-indent body-block)))
4a987e2b VS	469	(append header body (list "}"))))
cc4f1551	470
4a987e2b VS	471	(defprinter js-for-each (var object body-block)
4a987e2b VS	472	(let ((header (dwim-join (list (list (js-translate-symbol var))
cc4f1551	473	(list "in")
4a987e2b VS	474	(ps-print-indent object))
4a987e2b VS	475	(max-length)
cc4f1551 RD	476	:start "for (var "
cc4f1551 RD	477	:end ") {"))
4a987e2b VS	478	(body (ps-print-indent body-block)))
4a987e2b VS	479	(append header body (list "}"))))
cc4f1551	480
4a987e2b VS	481	(defprinter js-while (test body-block)
	482	(let ((header-strings (dwim-join (list (ps-print-indent test))
	483	(max-length)
cc4f1551 RD	484	:start "while ("
cc4f1551 RD	485	:end ") {"))
4a987e2b VS	486	(body-strings (ps-print-indent body-block)))
	487	(append header-strings body-strings (list "}"))))
	488
	489	(defprinter js-with (expression body-block)
	490	(append (dwim-join (list (ps-print-indent expression))
	491	(max-length)
	492	:start "with (" :end ") {")
	493	(ps-print-indent body-block)
	494	(list "}")))
	495
	496	(defprinter js-switch (test clauses)
	497	(let ((body-strings (mapcar (lambda (clause)
	498	(let ((val (first clause))
	499	(body-block (second clause)))
	500	(dwim-join (list (if (eql val 'default)
	501	(list "")
	502	(ps-print-indent val))
	503	(ps-print-indent body-block))
	504	(max-length)
	505	:start (if (eql val 'default) " default" " case ")
	506	:white-space " "
	507	:join-after ":")))
	508	clauses)))
	509	(append (dwim-join (list (ps-print-indent test))
	510	(max-length)
	511	:start "switch (" :end ") {")
	512	(reduce #'append body-strings)
	513	(list "}"))))
	514
	515	(defprinter js-try (body &key catch finally)
	516	(let ((catch-strings (when catch
	517	(append (dwim-join (list (list (js-translate-symbol (first catch))))
	518	(max-length)
	519	:start "} catch ("
	520	:end ") {")
	521	(ps-print-indent (second catch)))))
	522	(finally-strings (when finally
	523	(append (list "} finally {")
	524	(ps-print-indent finally)))))
	525	(append (list "try {")
	526	(ps-print-indent body)
	527	catch-strings
	528	finally-strings
	529	(list "}"))))
cc4f1551 RD	530
cc4f1551 RD	531	;;; regex
4a987e2b VS	532	(defprinter js-regex (regex)
	533	(flet ((first-slash-p (string)
	534	(and (> (length string) 0) (eql (char string 0) '#\/))))
	535	(let ((slash (unless (first-slash-p regex) "/")))
	536	(list (format nil (concatenate 'string slash "~A" slash) regex)))))
cc4f1551	537
4a987e2b VS	538	(defprinter js-return (value)
	539	(let ((printed-value (ps-print value 0)))
	540	(cons (concatenate 'string "return " (car printed-value)) (cdr printed-value))))
cc4f1551 RD	541
cc4f1551 RD	542	;;; conditional compilation
4a987e2b VS	543	(defprinter cc-if (test body-forms)
	544	(append (list (format nil "/*@if ~A" test))
	545	(mapcar (lambda (x) (ps-print x %start-pos%)) body-forms)
	546	(list "@end @*/")))
cc4f1551 RD	547
cc4f1551 RD	548	;;; TODO instanceof
4a987e2b VS	549	(defprinter js-instanceof (value type)
	550	(dwim-join (list (ps-print-indent value)
	551	(list "instanceof")
	552	(ps-print-indent type))
	553	(max-length)
	554	:start "("
	555	:end ")"
	556	:white-space " "))
	557
	558	(defprinter js-named-operator (op value)
	559	(dwim-join (list (ps-print-indent value))
	560	(max-length)
	561	:start (concatenate 'string (string-downcase (symbol-name op)) " ")
	562	:white-space " "))