From 839600e94160ca2775931e5f7a2fe23903a7ddf7 Mon Sep 17 00:00:00 2001
From: Vladimir Sedach <vsedach@gmail.com>
Date: Wed, 15 Aug 2007 01:07:08 +0000
Subject: [PATCH] Reworked printing implementation to get rid of dwim-join and
 gratuitious consing.

Now everything gets written to a stream.
---
 src/compilation-interface.lisp |   61 +-
 src/js-macrology.lisp          |   35 +-
 src/js-translation.lisp        | 1003 ++++++++++++++------------------
 3 files changed, 476 insertions(+), 623 deletions(-)
 rewrite src/compilation-interface.lisp (81%)
 rewrite src/js-translation.lisp (79%)

diff --git a/src/compilation-interface.lisp b/src/compilation-interface.lisp
dissimilarity index 81%
index 7780eec..3c17258 100644
--- a/src/compilation-interface.lisp
+++ b/src/compilation-interface.lisp
@@ -1,44 +1,17 @@
-(in-package :parenscript)
-
-(defun translate-ast (compiled-expr &key (output-stream *standard-output*) (output-spec :javascript) (pretty-print t))
-  "Translates a compiled Parenscript program (compiled with COMPILE-PAREN-FORM)
-to a Javascript string.  Outputs to the stream OUTPUT-STREAM in the language given
-by OUTPUT-SPEC, pretty printing if PRETTY-PRINT is non-null.
-
-OUTPUT-SPEC must be :javascript at the moment."
-  (when (not (eql :javascript output-spec))
-    (error "Unsupported output-spec for translation: ~A" output-spec))
-  (write-string (string-join (ps-print compiled-expr 0)
-                             (string #\Newline))
-                output-stream))
-
-(defun compile-script (script-form &key (output-spec :javascript) (pretty-print t) (output-stream nil) (toplevel-p t))
-  "Compiles the Parenscript form SCRIPT-FORM into the language specified by OUTPUT-SPEC.
-Non-null PRETTY-PRINT values result in a pretty-printed output code.  If OUTPUT-STREAM
-is NIL, then the result is a string; otherwise code is output to the OUTPUT-STREAM stream.
-
-This is the main function used by Parenscript users to compile their code to Javascript (and
-potentially other languages)."
-  (macrolet ((with-output-stream ((var) &body body)
-	       `(if (null output-stream)
-		 (with-output-to-string (,var)
-		   ,@body)
-		 (let ((,var output-stream))
-		   ,@body))))
-    (with-output-stream (stream)
-      (translate-ast (compile-parenscript-form script-form)
-                     :output-stream stream
-                     :output-spec output-spec
-                     :pretty-print pretty-print))))
-
-(defun ps-to-string (expr)
-  (string-join (ps-print (compile-parenscript-form expr) 0) (string #\Newline)))
-
-(defmacro ps (&body body)
-  "A macro that returns a Javascript string of the supplied Parenscript forms."
-  `(ps* '(progn ,@body)))
-
-(defun ps* (&rest body)
-  "Return the javascript string representing BODY.
-Body is evaluated."
-  (compile-script `(progn ,@body)))
+(in-package :parenscript)
+
+(defun compile-script (script-form &key (output-stream nil))
+  "Compiles the Parenscript form SCRIPT-FORM into Javascript.
+Non-null PRETTY-PRINT values result in a pretty-printed output code.
+If OUTPUT-STREAM is NIL, then the result is a string; otherwise code
+is output to the OUTPUT-STREAM stream."
+  (parenscript-print (compile-parenscript-form script-form) output-stream))
+
+(defmacro ps (&body body)
+  "A macro that returns a Javascript string of the supplied Parenscript forms."
+  `(ps* '(progn ,@body)))
+
+(defun ps* (&rest body)
+  "Return the javascript string representing BODY.
+Body is evaluated."
+  (compile-script `(progn ,@body)))
diff --git a/src/js-macrology.lisp b/src/js-macrology.lisp
index 4bdecf5..c67e009 100644
--- a/src/js-macrology.lisp
+++ b/src/js-macrology.lisp
@@ -74,19 +74,19 @@
 (define-ps-special-form ~ (expecting x)
   (list 'unary-operator "~" (compile-parenscript-form x :expecting :expressin) :prefix t))
 
-(defun flatten-progns (body)
-  (unless (null body)
+(defun flatten-blocks (body)
+  (when body
     (if (and (listp (car body))
-             (eql 'progn (caar body)))
-        (append (cdar body) (flatten-progns (cdr body)))
-        (cons (car body) (flatten-progns (cdr body))))))
+             (eql 'js-block (caar body)))
+        (append (third (car body)) (flatten-blocks (cdr body)))
+        (cons (car body) (flatten-blocks (cdr body))))))
 
 (define-ps-special-form progn (expecting &rest body)
   (list 'js-block
         (if (eql expecting :statement) t nil)
-        (remove nil (mapcar (lambda (form)
-                              (compile-parenscript-form form :expecting :statement))
-                            (flatten-progns body)))))
+        (flatten-blocks (remove nil (mapcar (lambda (form)
+                                              (compile-parenscript-form form :expecting :statement))
+                                            body)))))
 
 ;;; function definition
 (define-ps-special-form %js-lambda (expecting args &rest body)
@@ -123,8 +123,7 @@
                            (destructuring-bind (test &rest body)
                                clause
                              (list (compile-parenscript-form test :expecting :expression)
-                                   (mapcar (lambda (form) (compile-parenscript-form form :expecting :statement))
-                                           body))))
+                                   (compile-parenscript-form `(progn ,@body)))))
                          clauses)))
 
 (define-ps-special-form if (expecting test then &optional else)
@@ -232,6 +231,8 @@
   (let ((catch (cdr (assoc :catch clauses)))
         (finally (cdr (assoc :finally clauses))))
     (assert (not (cdar catch)) nil "Sorry, currently only simple catch forms are supported.")
+    (assert (or catch finally) ()
+            "Try form should have either a catch or a finally clause or both.")
     (list 'js-try (compile-parenscript-form `(progn ,form))
           :catch (when catch (list (compile-parenscript-form (caar catch) :expecting :symbol)
                                    (compile-parenscript-form `(progn ,@(cdr catch)))))
@@ -270,17 +271,17 @@
 (defpsmacro 1+ (form)
   `(+ ,form 1))
 
-;;; helper macros
+;;; inlining macros
 (define-ps-special-form js (expecting &rest body)
-  (string-join (ps-print (compile-parenscript-form `(progn ,@body)) 0) " "))
+  (parenscript-print (compile-parenscript-form `(progn ,@body))))
 
 (define-ps-special-form ps-inline (expecting &rest body)
   (concatenate 'string
                "javascript:"
-               (string-join (reduce #'append (mapcar (lambda (form)
-                                                       (ps-print (compile-parenscript-form form :expecting :statement)
-                                                                 0))
-                                                     body))
-                            ";")
+               (reduce (lambda (str1 str2)
+                         (concatenate 'string str1 ";" str2))
+                       (mapcar (lambda (form)
+                                 (parenscript-print (compile-parenscript-form form :expecting :statement)))
+                               body))
                ";"))
 
diff --git a/src/js-translation.lisp b/src/js-translation.lisp
dissimilarity index 79%
index b4aacd0..65ce5e2 100644
--- a/src/js-translation.lisp
+++ b/src/js-translation.lisp
@@ -1,562 +1,441 @@
-(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 "  "))
+(in-package :parenscript)
+
+(defvar *ps-output-stream*)
+
+(defmethod parenscript-print (ps-form &optional *ps-output-stream*)
+  (flet ((print-ps (form)
+           (let ((*standard-output* *ps-output-stream*))
+             (ps-print form))))
+    (if *ps-output-stream*
+        (print-ps ps-form)
+        (with-output-to-string (*ps-output-stream*)
+          (print-ps ps-form)))))
+
+(defgeneric ps-print% (special-form-name special-form-args))
+
+(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)
+      (declare (ignore ,sf))
+      (destructuring-bind ,content-args
+          ,sf-args
+        ,@body))))
+
+(defgeneric ps-print (compiled-form))
+
+(defmethod ps-print ((compiled-form cons))
+  "Prints the given compiled ParenScript form starting at the given
+indent position."
+  (ps-print% (car compiled-form) (cdr compiled-form)))
+
+;;; 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))
+  (flet ((lisp-special-char-to-js (lisp-char)
+           (car (rassoc lisp-char *js-lisp-escaped-chars*))))
+    (write-char *js-quote-char*)
+    (loop for char across string
+          for code = (char-code char)
+          for special = (lisp-special-char-to-js char)
+          do (cond (special (write-char #\\)
+                            (write-char special))
+                   ((or (<= code #x1f) (>= code #x80))
+                    (format *ps-output-stream* "\\u~4,'0x" code))
+                   (t (write-char char)))
+          finally (write-char *js-quote-char*))))
+
+(defmethod ps-print ((number number))
+  (format *ps-output-stream* (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*)))
+
+(defprinter script-quote (val)
+  (if (null val)
+      (write-string "null")
+      (error "Cannot translate quoted value ~S to javascript" val)))
+
+(defprinter js-literal (str)
+  (write-string str))
+
+(defprinter js-keyword (str)
+  (write-string str))
+
+(defun print-comma-list (ps-forms)
+  (loop for (form . rest) on ps-forms
+        with after = ", "
+        unless rest do (setf after "")
+        doing (progn (ps-print form)
+                     (write-string after))))
+
+(defprinter array-literal (&rest initial-contents)
+  (write-char #\[)
+  (print-comma-list initial-contents)
+  (write-char #\]))
+
+(defprinter js-aref (array indices)
+  (ps-print array)
+  (loop for idx in indices do
+        (progn (write-char #\[)
+               (ps-print idx)
+               (write-char #\]))))
+
+(defprinter object-literal (&rest slot-definitions)
+  (write-char #\{)
+  (loop for ((key . value) . rest) on slot-definitions
+        with after = ", "
+        unless rest do (setf after "")
+        doing (progn (format *ps-output-stream* "~A: " (js-translate-symbol key))
+                     (ps-print value)
+                     (write-string after)))
+  (write-string " }"))
+
+(defprinter js-variable (var)
+  (write-string (js-translate-symbol var)))
+
+;;; arithmetic operators
+(defun script-convert-op-name (op)
+  (case op
+    (and '\&\&)
+    (or '\|\|)
+    (not '!)
+    (eql '\=\=)
+    (=   '\=\=)
+    (t op)))
+
+(defun parenthesize-print (ps-form)
+  (write-char #\()
+  (ps-print ps-form)
+  (write-char #\)))
+
+(defprinter operator (op args)
+  (loop for (arg . rest) on args
+        with precedence = (op-precedence op)
+        with op-string = (format nil " ~A " op)
+        unless rest do (setf op-string "")
+        do (progn (if (>= (expression-precedence arg) precedence)
+                      (parenthesize-print arg)
+                      (ps-print arg))
+                  (write-string op-string))))
+
+(defprinter unary-operator (op arg &key prefix)
+  (when prefix
+    (write-string op))
+  (if (eql 'operator (car arg))
+      (parenthesize-print arg)
+      (ps-print arg))
+  (unless prefix
+    (write-string op)))
+
+;;; function and method calls
+(defprinter js-funcall (fun-designator args)
+  (cond ((member (car fun-designator) '(js-variable js-aref js-slot-value))
+         (ps-print fun-designator))
+        ((eql 'js-lambda (car fun-designator))
+         (write-char #\()
+         (ps-print fun-designator)
+         (write-char #\)))
+        ((eql 'js-funcall (car fun-designator))
+         (ps-print fun-designator)))
+  (write-char #\()
+  (print-comma-list args)
+  (write-char #\)))
+
+(defprinter js-method-call (method object args)
+  ;; 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
+  (if (or (numberp object) (and (consp object) (member (car object) '(js-lambda js-object operator js-expression-if js-block))))
+      (parenthesize-print object)
+      (ps-print object))
+  (write-string (js-translate-symbol method))
+  (write-char #\()
+  (print-comma-list args)
+  (write-char #\)))
+
+(defprinter js-block (statement-p statements)
+  (loop for (statement . rest) on statements
+        with indent = (if statement-p "    " "")
+        with after = (if statement-p
+                         ";
+"
+                         ", ")
+        unless rest do (setf after (if statement-p after ""))
+        do (progn (write-string indent)
+                  (ps-print statement)
+                  (write-string after))))
+
+(defprinter js-lambda (args body)
+  (print-fun-def nil args body))
+
+(defprinter js-defun (name args body)
+  (print-fun-def name args body))
+
+(defun print-fun-def (name args body)
+  (format *ps-output-stream* "function ~:[~;~A~](" name (js-translate-symbol name))
+  (loop for (arg . rest) on args
+        with after = ", "
+        unless rest do (setf after "")
+        do (progn (write-string (js-translate-symbol arg))
+                  (write-string after))
+        finally (write-string ") {"))
+  (fresh-line)
+  (ps-print body)
+  (write-char #\}))
+
+;;; object creation
+(defprinter js-object (slot-defs)
+  (write-string "{ ")
+  (loop for ((slot-name slot-value) . rest) on slot-defs
+        with after = ", "
+        unless rest do (setf after "")
+        do (progn (if (and (listp slot-name) (eql 'script-quote (car slot-name)) (symbolp (second slot-name)))
+                      (write-string (js-translate-symbol (second slot-name)))
+                      (ps-print slot-name))
+                  (write-string " : ")
+                  (ps-print slot-value)
+                  (write-string after)))
+  (write-string " }"))
+
+(defprinter js-slot-value (obj slot)
+  (if (and (listp obj) (member (car obj) '(js-block js-expression-if)))
+      (parenthesize-print obj)
+      (ps-print obj))
+  (if (and (listp slot) (eql 'script-quote (car slot)))
+      (progn (write-char #\.)
+             (if (symbolp (second slot))
+                 (write-string (js-translate-symbol (second slot)))
+                 (ps-print slot)))
+      (progn (write-char #\[)
+             (ps-print slot)
+             (write-char #\]))))
+
+;;; cond
+(defprinter js-cond (clauses)
+  (loop for (test body-block) in clauses
+        for start = "if (" then "else if ("
+        do (progn (if (string= test "true")
+                      (progn (write-string "else {")
+                             (fresh-line))
+                      (progn (ps-print test)
+                             (write-string ") {")
+                             (fresh-line)))
+                  (ps-print body-block)
+                  (write-char #\}))))
+
+(defprinter js-statement-if (test then else)
+  (write-string "if (")
+  (ps-print test)
+  (write-string ") {")
+  (fresh-line)
+  (ps-print then)
+  (fresh-line)
+  (when else
+      (write-string "} else {")
+      (fresh-line)
+      (ps-print else))
+  (write-char #\}))
+
+(defprinter js-expression-if (test then else)
+  (ps-print test)
+  (write-string " ? ")
+  (if (>= (expression-precedence then) (op-precedence 'js-expression-if))
+      (parenthesize-print then)
+      (ps-print then))
+  (write-string " : ")
+  (if else
+      (if (>= (expression-precedence else) (op-precedence 'js-expression-if))
+          (parenthesize-print else)
+          (ps-print else))
+      (write-string "undefined")))
+
+(defprinter js-assign (lhs rhs)
+  (ps-print lhs)
+  (write-string " = ")
+  (ps-print rhs))
+
+(defprinter js-defvar (var-name &rest var-value)
+  (write-string "var ")
+  (write-string (js-translate-symbol var-name))
+  (when var-value
+    (write-string " = ")
+    (ps-print (car var-value))))
+
+;;; iteration
+(defprinter js-for (vars steps test body-block)
+  (write-string "for (")
+  (loop for ((var-name . var-init) . rest) on vars
+        for decl = "var " then ""
+        with after = ", "
+        unless rest do (setf after "")
+        do (progn (write-string decl)
+                  (write-string (js-translate-symbol var-name))
+                  (write-string " = ")
+                  (ps-print var-init)
+                  (write-string after)))
+  (write-string "; ")
+  (ps-print test)
+  (write-string "; ")
+  (loop for ((var-name . var-init) . rest) on vars
+        for step in steps
+        with after = ", "
+        unless rest do (setf after "")
+        do (progn (write-string (js-translate-symbol var-name))
+                  (write-string " = ")
+                  (ps-print step)
+                  (write-string after)))
+  (write-string ") {")
+  (fresh-line)
+  (ps-print body-block)
+  (write-char #\}))
+
+(defprinter js-for-each (var object body-block)
+  (write-string "for (var ")
+  (write-string (js-translate-symbol var))
+  (write-string " in ")
+  (ps-print object)
+  (write-string ") {")
+  (fresh-line)
+  (ps-print body-block)
+  (write-char #\}))
+
+(defprinter js-while (test body-block)
+  (write-string "while (")
+  (ps-print test)
+  (write-string ") {")
+  (fresh-line)
+  (ps-print body-block)
+  (write-char #\}))
+
+(defprinter js-with (expression body-block)
+  (write-string "with (")
+  (ps-print expression)
+  (write-string ") {")
+  (fresh-line)
+  (ps-print body-block)
+  (write-char #\}))
+
+(defprinter js-switch (test clauses)
+  (write-string "switch (")
+  (ps-print test)
+  (write-string ") {")
+  (fresh-line)
+  (loop for (val body-block) in clauses
+        do (if (eql val 'default)
+               (progn (write-string "default: ")
+                      (ps-print body-block))
+               (progn (write-string "case ")
+                      (ps-print val)
+                      (write-char #\:)
+                      (fresh-line)
+                      (ps-print body-block))))
+  (write-char #\}))
+
+(defprinter js-try (body &key catch finally)
+  (write-string "try {")
+  (fresh-line)
+  (ps-print body)
+  (when catch
+    (write-string "} catch (")
+    (write-string (js-translate-symbol (first catch)))
+    (write-string ") {")
+    (ps-print (second catch)))
+  (when finally
+    (write-string "} finally {")
+    (ps-print finally))
+  (write-char #\}))
+
+;;; regex
+(defprinter js-regex (regex)
+  (flet ((first-slash-p (string)
+           (and (> (length string) 0) (char= (char string 0) #\/))))
+    (let ((slash (unless (first-slash-p regex) "/")))
+      (format *ps-output-stream* (concatenate 'string slash "~A" slash) regex))))
+
+(defprinter js-return (value)
+  (write-sequence "return " *ps-output-stream*)
+  (ps-print value))
+
+;;; conditional compilation
+(defprinter cc-if (test body-forms)
+  (write-string "/*@if ")
+  (ps-print test)
+  (fresh-line)
+  (dolist (form body-forms)
+    (ps-print form))
+  (fresh-line)
+  (write-string "@end @*/"))
+
+(defprinter js-instanceof (value type)
+  (write-char #\()
+  (ps-print value)
+  (write-string " instanceof ")
+  (ps-print type)
+  (write-char #\)))
+
+(defprinter js-named-operator (op value)
+  (format *ps-output-stream* "~(~A~) " op)
+  (ps-print value))
-- 
2.20.1