1 (in-package "PARENSCRIPT")
3 (defvar *ps-print-pretty
* t
)
4 (defvar *indent-num-spaces
* 4)
5 (defvar *js-string-delimiter
* #\'
6 "Specifies which character should be used for delimiting strings.
8 This variable is used when you want to embed the resulting JavaScript
9 in an html attribute delimited by #\\\" as opposed to #\\', or
12 (defvar *indent-level
*)
13 (defvar *print-accumulator
*)
15 (defmethod parenscript-print (form)
16 (let ((*indent-level
* 0)
17 (*print-accumulator
* ()))
18 (if (and (listp form
) (eq 'js
:block
(car form
))) ; ignore top-level block
19 (loop for
(statement . remaining
) on
(cdr form
) do
20 (ps-print statement
) (psw ";") (when remaining
(psw #\Newline
)))
22 (nreverse *print-accumulator
*)))
25 (push (if (characterp obj
) (string obj
) obj
) *print-accumulator
*))
27 (defgeneric ps-print%
(special-form-name special-form-args
))
29 (defmacro defprinter
(special-form content-args
&body body
)
30 "Given a special-form name and a destructuring lambda-list for its
31 arguments, defines a printer for that form using the given body."
34 `(defmethod ps-print%
((,sf
(eql ',special-form
)) ,sf-args
)
35 (declare (ignorable ,sf
))
36 (destructuring-bind ,content-args
40 (defgeneric ps-print
(compiled-form))
42 (defmethod ps-print ((form null
))) ; don't print top-level nils (ex: result of defining macros, etc.)
44 (defmethod ps-print ((s symbol
))
46 (ps-print (string-downcase s
)))
48 (defmethod ps-print ((compiled-form cons
))
49 (ps-print%
(car compiled-form
) (cdr compiled-form
)))
51 (defun newline-and-indent ()
53 (progn (psw #\Newline
)
54 (loop repeat
(* *indent-level
* *indent-num-spaces
*) do
(psw #\Space
)))
57 (defparameter *js-lisp-escaped-chars
*
61 (#\f .
#.
(code-char 12))
66 (defmethod ps-print ((string string
))
67 (flet ((lisp-special-char-to-js (lisp-char)
68 (car (rassoc lisp-char
*js-lisp-escaped-chars
*))))
69 (psw *js-string-delimiter
*)
70 (loop for char across string
71 for code
= (char-code char
)
72 for special
= (lisp-special-char-to-js char
)
73 do
(cond (special (psw #\\) (psw special
))
74 ((or (<= code
#x1f
) (>= code
#x80
)) (psw (format nil
"\\u~4,'0x" code
)))
76 (psw *js-string-delimiter
*)))
78 (defmethod ps-print ((number number
))
79 (psw (format nil
(if (integerp number
) "~S" "~F") number
)))
81 ;;; expression and operator precedence rules
83 (defun expression-precedence (expr)
86 ((js:slot-value js
:aref
) (op-precedence (car expr
)))
87 (js:= (op-precedence 'js
:=))
88 (js:?
(op-precedence 'js
:?
))
89 (js:unary-operator
(op-precedence (second expr
)))
90 (operator (op-precedence (second expr
)))
94 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
95 (defparameter *op-precedence-hash
* (make-hash-table :test
'eq
))
98 (dolist (ops '((js:new js
:slot-value js
:aref
)
100 (delete void typeof
++ -- unary
+ unary- ~
!)
104 (< > <= >= js
:instanceof js
:in
)
112 (= *= /= %
= += -
= <<= >>= >>>= \
&\
= ^
= \|
=)
115 (setf (gethash op
*op-precedence-hash
*) precedence
))
118 (defun op-precedence (op)
119 (gethash op
*op-precedence-hash
*)))
121 (defprinter js
:literal
(str)
124 (defun print-comma-delimited-list (ps-forms)
125 (loop for
(form . remaining
) on ps-forms do
126 (ps-print form
) (when remaining
(psw ", "))))
128 (defprinter js
:array
(&rest initial-contents
)
129 (psw #\
[) (print-comma-delimited-list initial-contents
) (psw #\
]))
131 (defprinter js
:aref
(array indices
)
132 (if (>= (expression-precedence array
) #.
(op-precedence 'js
:aref
))
133 (parenthesize-print array
)
135 (loop for idx in indices do
136 (psw #\
[) (ps-print idx
) (psw #\
])))
138 (defprinter js
:variable
(var)
139 (psw (symbol-to-js-string var
)))
141 ;;; arithmetic operators
142 (defun parenthesize-print (ps-form)
143 (psw #\
() (ps-print ps-form
) (psw #\
)))
145 (defprinter js
:operator
(op &rest args
)
146 (loop for
(arg . remaining
) on args
147 with precedence
= (op-precedence op
) do
148 (if (>= (expression-precedence arg
) precedence
)
149 (parenthesize-print arg
)
151 (when remaining
(psw (format nil
" ~(~A~) " op
)))))
153 (defprinter js
:unary-operator
(op arg
&key prefix space
)
154 (when prefix
(psw (format nil
"~(~a~)~:[~; ~]" op space
)))
155 (if (> (expression-precedence arg
)
156 (op-precedence (case op
160 (parenthesize-print arg
)
162 (unless prefix
(psw (format nil
"~(~a~)" op
))))
164 (defprinter js
:funcall
(fun-designator &rest args
)
165 (funcall (if (member (car fun-designator
) '(js:variable js
:aref js
:slot-value js
:funcall
))
167 #'parenthesize-print
)
169 (psw #\
() (print-comma-delimited-list args
) (psw #\
)))
171 (defprinter js
:|
,|
(&rest expressions
)
173 (loop for
(exp . remaining
) on expressions do
174 (ps-print exp
) (when remaining
(psw ", ")))
177 (defprinter js
:block
(&rest statements
)
179 (incf *indent-level
*)
180 (dolist (statement statements
)
181 (newline-and-indent) (ps-print statement
) (psw #\
;))
182 (decf *indent-level
*)
186 (defprinter js
:lambda
(args body
)
187 (print-fun-def nil args body
))
189 (defprinter js
:defun
(name args body
)
190 (print-fun-def name args body
))
192 (defun print-fun-def (name args body-block
)
193 (psw (format nil
"function ~:[~;~A~](" name
(symbol-to-js-string name
)))
194 (loop for
(arg . remaining
) on args do
195 (psw (symbol-to-js-string arg
)) (when remaining
(psw ", ")))
197 (ps-print body-block
))
199 (defprinter js
:object
(&rest slot-defs
)
201 (loop for
((slot-name . slot-value
) . remaining
) on slot-defs do
202 (if (and (listp slot-name
) (eq 'quote
(car slot-name
)) (symbolp (second slot-name
)))
203 (psw (symbol-to-js-string (second slot-name
)))
204 (ps-print slot-name
))
206 (ps-print slot-value
)
207 (when remaining
(psw ", ")))
210 (defprinter js
:slot-value
(obj slot
)
211 (if (or (> (expression-precedence obj
) #.
(op-precedence 'js
:slot-value
))
213 (and (listp obj
) (member (car obj
) '(js:lambda js
:object
))))
214 (parenthesize-print obj
)
217 (progn (psw #\.
) (psw (symbol-to-js-string slot
)))
218 (progn (psw #\
[) (ps-print slot
) (psw #\
]))))
220 (defprinter js
:if
(test consequent
&rest clauses
)
221 (psw "if (") (ps-print test
) (psw ") ")
222 (ps-print consequent
)
223 (loop while clauses do
225 (:else-if
(psw " else if (") (ps-print (cadr clauses
)) (psw ") ")
226 (ps-print (caddr clauses
))
227 (setf clauses
(cdddr clauses
)))
228 (:else
(psw " else ")
229 (ps-print (cadr clauses
))
232 (defprinter js
:?
(test then else
)
233 (if (>= (expression-precedence test
) (op-precedence 'js
:?
))
234 (parenthesize-print test
)
237 (if (>= (expression-precedence then
) (op-precedence 'js
:?
))
238 (parenthesize-print then
)
241 (if (>= (expression-precedence else
) (op-precedence 'js
:?
))
242 (parenthesize-print else
)
245 (defprinter js
:= (lhs rhs
)
246 (ps-print lhs
) (psw " = ") (ps-print rhs
))
248 (defprinter js
:var
(var-name &rest var-value
)
250 (psw (symbol-to-js-string var-name
))
253 (ps-print (car var-value
))))
255 (defprinter js
:break
(&optional label
)
259 (psw (symbol-to-js-string label
))))
261 (defprinter js
:continue
(&optional label
)
265 (psw (symbol-to-js-string label
))))
268 (defprinter js
:for
(label vars tests steps body-block
)
269 (when label
(psw (symbol-to-js-string label
)) (psw ": ") (newline-and-indent))
271 (loop for
((var-name . var-init
) . remaining
) on vars
272 for decl
= "var " then
"" do
273 (psw decl
) (psw (symbol-to-js-string var-name
)) (psw " = ") (ps-print var-init
) (when remaining
(psw ", ")))
275 (loop for
(test . remaining
) on tests do
276 (ps-print test
) (when remaining
(psw ", ")))
278 (loop for
(step . remaining
) on steps do
279 (ps-print step
) (when remaining
(psw ", ")))
281 (ps-print body-block
))
283 (defprinter js
:for-in
(var object body-block
)
284 (psw "for (var ") (ps-print var
) (psw " in ")
285 (if (> (expression-precedence object
) (op-precedence 'in
))
286 (parenthesize-print object
)
289 (ps-print body-block
))
291 (defprinter js
:while
(test body-block
)
292 (psw "while (") (ps-print test
) (psw ") ")
293 (ps-print body-block
))
295 (defprinter js
:with
(expression body-block
)
296 (psw "with (") (ps-print expression
) (psw ") ")
297 (ps-print body-block
))
299 (defprinter js
:switch
(test clauses
)
300 (flet ((print-body-statements (body-statements)
301 (incf *indent-level
*)
302 (loop for statement in body-statements do
303 (progn (newline-and-indent)
306 (decf *indent-level
*)))
307 (psw "switch (") (ps-print test
) (psw ") {")
308 (loop for
(val . statements
) in clauses
309 do
(progn (newline-and-indent)
310 (if (eq val
'default
)
311 (progn (psw "default: ")
312 (print-body-statements statements
))
316 (print-body-statements statements
)))))
320 (defprinter js
:try
(body-block &key catch finally
)
322 (ps-print body-block
)
324 (psw " catch (") (psw (symbol-to-js-string (first catch
))) (psw ") ")
325 (ps-print (second catch
)))
331 (defprinter js
:regex
(regex)
332 (flet ((first-slash-p (string)
333 (and (> (length string
) 0) (char= (char string
0) #\
/))))
334 (let ((slash (unless (first-slash-p regex
) "/")))
335 (psw (format nil
(concatenate 'string slash
"~A" slash
) regex
)))))
337 ;;; conditional compilation
338 (defprinter js
:cc-if
(test &rest body
)
341 (incf *indent-level
*)
343 (newline-and-indent) (ps-print form
) (psw #\
;))
344 (decf *indent-level
*)
348 (defprinter js
:instanceof
(value type
)
350 (if (> (expression-precedence value
) (op-precedence 'js
:instanceof
))
351 (parenthesize-print value
)
354 (if (> (expression-precedence type
) (op-precedence 'js
:instanceof
))
355 (parenthesize-print type
)
359 (defprinter js
:escape
(literal-js)
360 ;; literal-js should be a form that evaluates to a string containing valid JavaScript
364 (defprinter js
:throw
(x)
365 (psw "throw ") (ps-print x
))
367 (defprinter js
:return
(x)
368 (psw "return ") (ps-print x
))