(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*))
+(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) (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))
+ (reduce (lambda (acc next-token)
+ (if (and (stringp next-token)
+ (stringp (car (last acc))))
+ (append (butlast acc) (list (concatenate 'string (car (last acc)) next-token)))
+ (append acc (list next-token))))
+ (cons () (reverse *print-accumulator*)))))
+
+(defun psw (obj)
+ (push (if (characterp obj) (string obj) obj) *print-accumulator*))
(defgeneric ps-print% (special-form-name special-form-args))
(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 (js-translate-symbol 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*
+ (when (and (stringp (car *print-accumulator*))
+ (not (char= #\Newline (char (car *print-accumulator*) (1- (length (car *print-accumulator*))))))
+ (psw #\Newline))
+ (loop repeat (* *indent-level* *indent-num-spaces*) do (psw #\Space)))
+ (psw #\Space)))
(defparameter *js-lisp-escaped-chars*
'((#\' . #\')
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
(case (car expr)
((js-slot-value js-aref) (op-precedence (car expr)))
(js-assign (op-precedence '=))
- (js-expression-if (op-precedence 'js-expression-if))
+ (js:? (op-precedence 'js:?))
(unary-operator (op-precedence (second expr)))
(operator (op-precedence (second expr)))
(otherwise 0))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *op-precedence-hash* (make-hash-table :test 'eq))
- ;;; generate the operator precedences from *OP-PRECEDENCES*
(let ((precedence 1))
(dolist (ops '((new js-slot-value js-aref)
(postfix++ postfix--)
(\|)
(\&\& and)
(\|\| or)
- (js-expression-if)
+ (js:?)
(= *= /= %= += -= <<= >>= >>>= \&\= ^= \|= js-assign)
(comma)))
(dolist (op ops)
(defun op-precedence (op)
(gethash op *op-precedence-hash*)))
-(defprinter ps-quote (val)
- (if (null val)
- (psw "null")
- (error "Cannot translate quoted value ~S to javascript" val)))
-
(defprinter js-literal (str)
(psw str))
(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)))
(if (>= (expression-precedence arg) precedence)
(parenthesize-print arg)
(ps-print arg))
- (when remaining (format *ps-output-stream* " ~(~A~) " op))))
+ (when remaining (psw (format nil " ~(~A~) " op)))))
(defprinter unary-operator (op arg &key prefix space)
- (when prefix (format *ps-output-stream* "~(~a~)~:[~; ~]" op space))
+ (when prefix (psw (format nil "~(~a~)~:[~; ~]" op space)))
(if (> (expression-precedence arg)
(op-precedence (case op
(+ 'unary+)
(t op))))
(parenthesize-print arg)
(ps-print arg))
- (unless prefix (format *ps-output-stream* "~(~a~)" op)))
+ (unless prefix (psw (format nil "~(~a~)" 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 #\)))
-
-(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))
+ (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)
(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 (js-translate-symbol name)))
(loop for (arg . remaining) on args do
(psw (js-translate-symbol arg)) (when remaining (psw ", ")))
(psw ") ")
(ps-print body-block))
-;;; object literals
(defprinter js-object (slot-defs)
(psw "{ ")
- (loop for ((slot-name slot-value) . remaining) on slot-defs do
- (if (and (listp slot-name) (eql 'ps-quote (car slot-name)) (symbolp (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 (js-translate-symbol (second slot-name)))
(ps-print slot-name))
(psw " : ")
(psw " }"))
(defprinter js-slot-value (obj slot)
- (if (> (expression-precedence obj) #.(op-precedence 'js-slot-value))
+ (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 'ps-quote (car slot)))
- (progn (psw #\.)
- (if (symbolp (second slot))
- (psw (js-translate-symbol (second slot)))
- (ps-print slot)))
+ (if (symbolp slot)
+ (progn (psw #\.) (psw (js-translate-symbol slot)))
(progn (psw #\[) (ps-print slot) (psw #\]))))
(defprinter js-cond-statement (clauses)
(psw ") ")))
(ps-print body-block)))
-(defprinter js-statement-if (test then-block else-block)
+(defprinter js:if (test then-block else-block)
(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)
+(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)))
(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))))
+ (psw (format nil (concatenate 'string slash "~A" slash) regex)))))
;;; conditional compilation
(defprinter cc-if (test body-forms)
(ps-print type))
(psw #\)))
+(defprinter js-escape (lisp-form)
+ (psw `(ps1* ,lisp-form)))
+
;;; named statements
(macrolet ((def-stmt-printer (&rest stmts)
`(progn ,@(mapcar (lambda (stmt)
`(defprinter ,(intern (format nil "JS-~a" stmt)) (expr)
- (format *ps-output-stream* "~(~a~) " ',stmt)
+ (psw (format nil "~(~a~) " ',stmt))
(ps-print expr)))
stmts))))
(def-stmt-printer throw return))
-
HCoop / clinton / parenscript.git / blobdiff