-(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))
HCoop / clinton / parenscript.git / commitdiff