X-Git-Url: https://git.hcoop.net/clinton/parenscript.git/blobdiff_plain/1bfa6fabc0eb603bc7bedc70f9a763566a8912a7..dd4442b8973fe8b2c19b44f94f244934aa418ae8:/src/printer.lisp

diff --git a/src/printer.lisp b/src/printer.lisp
index b1e810c..dbeea7a 100644
--- a/src/printer.lisp
+++ b/src/printer.lisp
@@ -1,22 +1,28 @@
-(in-package :parenscript)
-
-(defvar *ps-output-stream*)
-(defparameter *indent-level* 0)
-
-(defmethod parenscript-print (ps-form &optional *ps-output-stream*)
-  (setf *indent-level* 0)
-  (flet ((print-ps (form)
-           (if (and (listp form) (eql 'js-block (car form))) ;; ignore top-level block
-               (loop for (statement . remaining) on (third form) do
-                     (ps-print statement) (psw ";") (when remaining (psw #\Newline)))
-               (ps-print form))))
-    (if *ps-output-stream*
-        (print-ps ps-form)
-        (with-output-to-string (*ps-output-stream*)
-          (print-ps ps-form)))))
-
-(defun psw (obj) ;; parenscript-write
-  (princ obj *ps-output-stream*))    
+(in-package "PARENSCRIPT")
+
+(defvar *ps-print-pretty* t)
+(defvar *indent-num-spaces* 4)
+(defvar *js-string-delimiter* #\'
+  "Specifies which character should be used for delimiting strings.
+
+This variable is used when you want to embed the resulting JavaScript
+in an html attribute delimited by #\\\" as opposed to #\\', or
+vice-versa.")
+
+(defvar *indent-level*)
+(defvar *print-accumulator*)
+
+(defmethod parenscript-print (form)
+  (let ((*indent-level* 0)
+        (*print-accumulator* ()))
+    (if (and (listp form) (eq 'js:block (car form))) ; ignore top-level block
+        (loop for (statement . remaining) on (cdr form) do
+             (ps-print statement) (psw ";") (when remaining (psw #\Newline)))
+        (ps-print form))
+    (nreverse *print-accumulator*)))
+
+(defun psw (obj)
+  (push (if (characterp obj) (string obj) obj) *print-accumulator*))
 
 (defgeneric ps-print% (special-form-name special-form-args))
 
@@ -33,30 +39,20 @@ arguments, defines a printer for that form using the given body."
 
 (defgeneric ps-print (compiled-form))
 
-(defmethod ps-print ((form null)) ;; don't print top-level nils (ex: result of defining macros, etc.)
-  )
+(defmethod ps-print ((form null))) ; don't print top-level nils (ex: result of defining macros, etc.)
+
+(defmethod ps-print ((s symbol))
+  (assert (keywordp s))
+  (ps-print (string-downcase s)))
 
 (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)))
 
-;;; indentation
-(defvar *ps-print-pretty* t)
-(defvar *indent-num-spaces* 4)
-
 (defun newline-and-indent ()
-  (when (and (fresh-line *ps-output-stream*) *ps-print-pretty*)
-    (loop repeat (* *indent-level* *indent-num-spaces*)
-          do (psw #\Space))))
-
-;;; string literals
-(defvar *js-string-delimiter* #\'
-  "Specifies which character should be used for delimiting strings.
-
-This variable is used when you want to embed the resulting JavaScript
-in an html attribute delimited by #\\\" as opposed to #\\', or
-vice-versa.")
+  (if *ps-print-pretty*
+      (progn (psw #\Newline)
+             (loop repeat (* *indent-level* *indent-num-spaces*) do (psw #\Space)))
+      (psw #\Space)))
 
 (defparameter *js-lisp-escaped-chars*
   '((#\' . #\')
@@ -75,256 +71,230 @@ vice-versa.")
           for code = (char-code char)
           for special = (lisp-special-char-to-js char)
           do (cond (special (psw #\\) (psw special))
-                   ((or (<= code #x1f) (>= code #x80))
-                    (format *ps-output-stream* "\\u~4,'0x" code))
+                   ((or (<= code #x1f) (>= code #x80)) (psw (format nil "\\u~4,'0x" code)))
                    (t (psw char))))
     (psw *js-string-delimiter*)))
 
 (defmethod ps-print ((number number))
-  (format *ps-output-stream* (if (integerp number) "~S" "~F") number))
+  (psw (format nil (if (integerp number) "~S" "~F") number)))
 
 ;;; expression and operator precedence rules
 
 (defun expression-precedence (expr)
   (if (consp expr)
       (case (car expr)
-        (js-expression-if (op-precedence 'js-expression-if))
-        (js-assign (op-precedence '=))
+        ((js:slot-value js:aref) (op-precedence (car expr)))
+        (js:= (op-precedence 'js:=))
+        (js:? (op-precedence 'js:?))
+        (js:unary-operator (op-precedence (second expr)))
         (operator (op-precedence (second expr)))
         (otherwise 0))
       0))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (defparameter *op-precedence-hash* (make-hash-table :test #'equal))
+  (defparameter *op-precedence-hash* (make-hash-table :test 'eq))
 
-  ;;; generate the operator precedences from *OP-PRECEDENCES*
   (let ((precedence 1))
-    (dolist (ops '((js-aref)
-                   (js-slot-value)
-                   (! not ~)
+    (dolist (ops '((js:new js:slot-value js:aref)
+                   (postfix++ postfix--)
+                   (delete void typeof ++ -- unary+ unary- ~ !)
                    (* / %)
                    (+ -)
-                   (<< >>)
-                   (>>>)
-                   (< > <= >=)
-                   (in js-expression-if)
-                   (eql == != =)
-                   (=== !==)
+                   (<< >> >>>)
+                   (< > <= >= js:instanceof js:in)
+                   (== != === !== eql)
                    (&)
                    (^)
                    (\|)
                    (\&\& and)
                    (\|\| or)
-                   (js-assign *= /= %= += -= <<= >>= >>>= \&= ^= \|=)
+                   (js:?)
+                   (= *= /= %= += -= <<= >>= >>>= \&\= ^= \|=)
                    (comma)))
       (dolist (op ops)
-        (let ((op-name (symbol-name op)))
-          (setf (gethash op-name *op-precedence-hash*) precedence)))
+        (setf (gethash op *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)
-      (psw "null")
-      (error "Cannot translate quoted value ~S to javascript" val)))
+    (gethash op *op-precedence-hash*)))
 
-(defprinter js-literal (str)
+(defprinter js:literal (str)
   (psw str))
 
 (defun print-comma-delimited-list (ps-forms)
   (loop for (form . remaining) on ps-forms do
         (ps-print form) (when remaining (psw ", "))))
 
-(defprinter array-literal (&rest initial-contents)
+(defprinter js:array (&rest initial-contents)
   (psw #\[) (print-comma-delimited-list initial-contents) (psw #\]))
 
-(defprinter js-aref (array indices)
-  (ps-print array)
+(defprinter js:aref (array indices)
+  (if (>= (expression-precedence array) #.(op-precedence 'js:aref))
+      (parenthesize-print array)
+      (ps-print array))
   (loop for idx in indices do
         (psw #\[) (ps-print idx) (psw #\])))
 
-(defprinter object-literal (&rest slot-definitions)
-  (psw #\{)
-  (loop for ((key . value) . remaining) on slot-definitions do
-        (format *ps-output-stream* "~A: " (js-translate-symbol key))
-        (ps-print value)
-        (when remaining (psw ", ")))
-  (psw " }"))
-
-(defprinter js-variable (var)
-  (psw (js-translate-symbol var)))
+(defprinter js:variable (var)
+  (psw (symbol-to-js-string var)))
 
 ;;; arithmetic operators
-(defun script-convert-op-name (op)
-  (case op
-    (and '\&\&)
-    (or '\|\|)
-    (not '!)
-    (eql '\=\=)
-    (=   '\=\=)
-    (t op)))
-
 (defun parenthesize-print (ps-form)
   (psw #\() (ps-print ps-form) (psw #\)))
 
-(defprinter operator (op args)
+(defprinter js:operator (op &rest args)
   (loop for (arg . remaining) on args
         with precedence = (op-precedence op) do
         (if (>= (expression-precedence arg) precedence)
             (parenthesize-print arg)
             (ps-print arg))
-        (when remaining (format *ps-output-stream* " ~A " op))))
-
-(defprinter unary-operator (op arg &key prefix)
-  (when prefix (psw op))
-  (if (and (listp arg) (eql 'operator (car arg)))
+        (when remaining (psw (format nil " ~(~A~) " op)))))
+
+(defprinter js:unary-operator (op arg &key prefix space)
+  (when prefix (psw (format nil "~(~a~)~:[~; ~]" op space)))
+  (if (> (expression-precedence arg)
+         (op-precedence (case op
+                          (+ 'unary+)
+                          (- 'unary-)
+                          (t op))))
       (parenthesize-print arg)
       (ps-print arg))
-  (unless prefix (psw 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))
-         (psw #\() (ps-print fun-designator) (psw #\)))
-        ((eql 'js-funcall (car fun-designator))
-         (ps-print fun-designator)))
-  (psw #\() (print-comma-delimited-list args) (psw #\)))
+  (unless prefix (psw (format nil "~(~a~)" op))))
 
-(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 lambdas
-  (if (or (numberp object) (and (consp object) (member (car object) '(js-lambda js-object operator js-expression-if))))
-      (parenthesize-print object)
-      (ps-print object))
-  (psw (js-translate-symbol method))
+(defprinter js:funcall (fun-designator &rest args)
+  (funcall (if (member (car fun-designator) '(js:variable js:aref js:slot-value js:funcall))
+               #'ps-print
+               #'parenthesize-print)
+           fun-designator)
   (psw #\() (print-comma-delimited-list args) (psw #\)))
 
-(defprinter js-block (block-type statements)
-  (case block-type
-    (:statement
-     (psw #\{)
-     (incf *indent-level*)
-     (dolist (statement statements)
-       (newline-and-indent) (ps-print statement) (psw #\;))
-     (decf *indent-level*)
-     (newline-and-indent)
-     (psw #\}))
-    (:expression
-     (psw #\()
-     (loop for (statement . remaining) on statements do
-           (ps-print statement) (when remaining (psw ", ")))
-     (psw #\)))))
-
-(defprinter js-lambda (args body)
+(defprinter js:|,| (&rest expressions)
+  (psw #\()
+  (loop for (exp . remaining) on expressions do
+       (ps-print exp) (when remaining (psw ", ")))
+  (psw #\)))
+
+(defprinter js:block (&rest statements)
+  (psw #\{)
+  (incf *indent-level*)
+  (dolist (statement statements)
+    (newline-and-indent) (ps-print statement) (psw #\;))
+  (decf *indent-level*)
+  (newline-and-indent)
+  (psw #\}))
+
+(defprinter js:lambda (args body)
   (print-fun-def nil args body))
 
-(defprinter js-defun (name args body)
+(defprinter js:defun (name args body)
   (print-fun-def name args body))
 
 (defun print-fun-def (name args body-block)
-  (format *ps-output-stream* "function ~:[~;~A~](" name (js-translate-symbol name))
+  (psw (format nil "function ~:[~;~A~](" name (symbol-to-js-string name)))
   (loop for (arg . remaining) on args do
-        (psw (js-translate-symbol arg)) (when remaining (psw ", ")))
+        (psw (symbol-to-js-string arg)) (when remaining (psw ", ")))
   (psw ") ")
   (ps-print body-block))
 
-;;; object literals
-(defprinter js-object (slot-defs)
+(defprinter js:object (&rest slot-defs)
   (psw "{ ")
-  (loop for ((slot-name slot-value) . remaining) on slot-defs do
-        (if (and (listp slot-name) (eql 'script-quote (car slot-name)) (symbolp (second slot-name)))
-            (psw (js-translate-symbol (second slot-name)))
+  (loop for ((slot-name . slot-value) . remaining) on slot-defs do
+        (if (and (listp slot-name) (eq 'quote (car slot-name)) (symbolp (second slot-name)))
+            (psw (symbol-to-js-string (second slot-name)))
             (ps-print slot-name))
         (psw " : ")
         (ps-print slot-value)
         (when remaining (psw ", ")))
   (psw " }"))
 
-(defprinter js-slot-value (obj slot)
-  (if (and (listp obj) (member (car obj) '(js-expression-if)))
+(defprinter js:slot-value (obj slot)
+  (if (or (> (expression-precedence obj) #.(op-precedence 'js:slot-value))
+          (numberp obj)
+          (and (listp obj) (member (car obj) '(js:lambda js:object))))
       (parenthesize-print obj)
       (ps-print obj))
-  (if (and (listp slot) (eql 'script-quote (car slot)))
-      (progn (psw #\.)
-             (if (symbolp (second slot))
-                 (psw (js-translate-symbol (second slot)))
-                 (ps-print slot)))
+  (if (symbolp slot)
+      (progn (psw #\.) (psw (symbol-to-js-string slot)))
       (progn (psw #\[) (ps-print slot) (psw #\]))))
 
-(defprinter js-cond-statement (clauses)
-  (loop for (test body-block) in clauses
-        for start = "if (" then " else if (" do
-        (if (equalp test "true")
-            (psw " else ")
-            (progn (psw start)
-                   (ps-print test)
-                   (psw ") ")))
-        (ps-print body-block)))
-
-(defprinter js-statement-if (test then-block else-block)
+(defprinter js:if (test consequent &rest clauses)
   (psw "if (") (ps-print test) (psw ") ")
-  (ps-print then-block)
-  (when else-block
-      (psw " else ")
-      (ps-print else-block)))
-
-(defprinter js-expression-if (test then else)
+  (ps-print consequent)
+  (loop while clauses do
+       (ecase (car clauses)
+         (:else-if (psw " else if (") (ps-print (cadr clauses)) (psw ") ")
+                   (ps-print (caddr clauses))
+                   (setf clauses (cdddr clauses)))
+         (:else (psw " else ")
+                (ps-print (cadr clauses))
+                (return)))))
+
+(defprinter js:? (test then else)
   (ps-print test)
   (psw " ? ")
-  (if (>= (expression-precedence then) (op-precedence 'js-expression-if))
+  (if (>= (expression-precedence then) (op-precedence 'js:?))
       (parenthesize-print then)
       (ps-print then))
   (psw " : ")
-  (if (>= (expression-precedence else) (op-precedence 'js-expression-if))
+  (if (>= (expression-precedence else) (op-precedence 'js:?))
       (parenthesize-print else)
       (ps-print else)))
 
-(defprinter js-assign (lhs rhs)
+(defprinter js:= (lhs rhs)
   (ps-print lhs) (psw " = ") (ps-print rhs))
 
-(defprinter js-defvar (var-name &rest var-value)
+(defprinter js:var (var-name &rest var-value)
   (psw "var ")
-  (psw (js-translate-symbol var-name))
+  (psw (symbol-to-js-string var-name))
   (when var-value
     (psw " = ")
     (ps-print (car var-value))))
 
+(defprinter js:break (&optional label)
+  (psw "break")
+  (when label
+    (psw " ")
+    (psw (symbol-to-js-string label))))
+
+(defprinter js:continue (&optional label)
+  (psw "continue")
+  (when label
+    (psw " ")
+    (psw (symbol-to-js-string label))))
+
 ;;; iteration
-(defprinter js-for (vars steps test body-block)
+(defprinter js:for (label vars tests steps body-block)
+  (when label (psw (symbol-to-js-string label)) (psw ": ") (newline-and-indent))
   (psw "for (")
   (loop for ((var-name . var-init) . remaining) on vars
         for decl = "var " then "" do
-        (psw decl) (psw (js-translate-symbol var-name)) (psw " = ") (ps-print var-init) (when remaining (psw ", ")))
+        (psw decl) (psw (symbol-to-js-string var-name)) (psw " = ") (ps-print var-init) (when remaining (psw ", ")))
   (psw "; ")
-  (ps-print test)
+  (loop for (test . remaining) on tests do
+       (ps-print test) (when remaining (psw ", ")))
   (psw "; ")
-  (loop for ((var-name . nil) . remaining) on vars
-        for step in steps do
-        (psw (js-translate-symbol var-name)) (psw " = ") (ps-print step) (when remaining (psw ", ")))
+  (loop for (step . remaining) on steps do
+       (ps-print step) (when remaining (psw ", ")))
   (psw ") ")
   (ps-print body-block))
 
-(defprinter js-for-each (var object body-block)
-  (psw "for (var ") (psw (js-translate-symbol var)) (psw " in ") (ps-print object) (psw ") ")
+(defprinter js:for-in (var object body-block)
+  (psw "for (") (ps-print var) (psw " in ")
+  (if (> (expression-precedence object) (op-precedence 'in))
+      (parenthesize-print object)
+      (ps-print object))
+  (psw ") ")
   (ps-print body-block))
 
-(defprinter js-while (test body-block)
+(defprinter js:while (test body-block)
   (psw "while (") (ps-print test) (psw ") ")
   (ps-print body-block))
 
-(defprinter js-with (expression body-block)
+(defprinter js:with (expression body-block)
   (psw "with (") (ps-print expression) (psw ") ")
   (ps-print body-block))
 
-(defprinter js-switch (test clauses)
+(defprinter js:switch (test clauses)
   (flet ((print-body-statements (body-statements)
            (incf *indent-level*)
            (loop for statement in body-statements do
@@ -335,7 +305,7 @@ vice-versa.")
     (psw "switch (") (ps-print test) (psw ") {")
     (loop for (val . statements) in clauses
           do (progn (newline-and-indent)
-                    (if (eql val 'default)
+                    (if (eq val 'default)
                         (progn (psw "default: ")
                                (print-body-statements statements))
                         (progn (psw "case ")
@@ -345,40 +315,52 @@ vice-versa.")
     (newline-and-indent)
     (psw #\})))
 
-(defprinter js-try (body-block &key catch finally)
+(defprinter js:try (body-block &key catch finally)
   (psw "try ")
   (ps-print body-block)
   (when catch
-    (psw " catch (") (psw (js-translate-symbol (first catch))) (psw ") ")
+    (psw " catch (") (psw (symbol-to-js-string (first catch))) (psw ") ")
     (ps-print (second catch)))
   (when finally
     (psw " finally ")
     (ps-print finally)))
 
 ;;; regex
-(defprinter js-regex (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)
-  (psw "return ") (ps-print value))
+      (psw (format nil (concatenate 'string slash "~A" slash) regex)))))
 
 ;;; conditional compilation
-(defprinter cc-if (test body-forms)
+(defprinter js:cc-if (test &rest body)
   (psw "/*@if ")
   (ps-print test)
   (incf *indent-level*)
-  (dolist (form body-forms)
+  (dolist (form body)
     (newline-and-indent) (ps-print form) (psw #\;))
   (decf *indent-level*)
   (newline-and-indent)
   (psw "@end @*/"))
 
-(defprinter js-instanceof (value type)
-  (psw #\() (ps-print value) (psw " instanceof ") (ps-print type) (psw #\)))
-
-(defprinter js-named-operator (op value)
-  (format *ps-output-stream* "~(~A~) " op)
-  (ps-print value))
+(defprinter js:instanceof (value type)
+  (psw #\()
+  (if (> (expression-precedence value) (op-precedence 'js:instanceof))
+      (parenthesize-print value)
+      (ps-print value))
+  (psw " instanceof ")
+  (if (> (expression-precedence type) (op-precedence 'js:instanceof))
+      (parenthesize-print type)
+      (ps-print type))
+  (psw #\)))
+
+(defprinter js:escape (literal-js)
+  ;; literal-js should be a form that evaluates to a string containing valid JavaScript
+  (psw literal-js))
+
+;;; named statements
+(defprinter js:throw (x)
+  (psw "throw ") (ps-print x))
+
+(defprinter js:return (x)
+  (psw "return ") (ps-print x))