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
) (eql 'js-block
(car form
))) ; ignore top-level block
19 (loop for
(statement . remaining
) on
(third form
) do
20 (ps-print statement
) (psw ";") (when remaining
(psw #\Newline
)))
22 (reduce (lambda (acc next-token
)
23 (if (and (stringp next-token
)
24 (stringp (car (last acc
))))
25 (append (butlast acc
) (list (concatenate 'string
(car (last acc
)) next-token
)))
26 (append acc
(list next-token
))))
27 (cons () (reverse *print-accumulator
*)))))
30 (push (if (characterp obj
) (string obj
) obj
) *print-accumulator
*))
32 (defgeneric ps-print%
(special-form-name special-form-args
))
34 (defmacro defprinter
(special-form content-args
&body body
)
35 "Given a special-form name and a destructuring lambda-list for its
36 arguments, defines a printer for that form using the given body."
39 `(defmethod ps-print%
((,sf
(eql ',special-form
)) ,sf-args
)
40 (declare (ignorable ,sf
))
41 (destructuring-bind ,content-args
45 (defgeneric ps-print
(compiled-form))
47 (defmethod ps-print ((form null
))) ; don't print top-level nils (ex: result of defining macros, etc.)
49 (defmethod ps-print ((s symbol
))
51 (ps-print (js-translate-symbol s
)))
53 (defmethod ps-print ((compiled-form cons
))
54 (ps-print%
(car compiled-form
) (cdr compiled-form
)))
56 (defun newline-and-indent ()
58 (when (and (stringp (car *print-accumulator
*))
59 (not (char= #\Newline
(char (car *print-accumulator
*) (1- (length (car *print-accumulator
*))))))
61 (loop repeat
(* *indent-level
* *indent-num-spaces
*) do
(psw #\Space
)))
64 (defparameter *js-lisp-escaped-chars
*
68 (#\f .
#.
(code-char 12))
73 (defmethod ps-print ((string string
))
74 (flet ((lisp-special-char-to-js (lisp-char)
75 (car (rassoc lisp-char
*js-lisp-escaped-chars
*))))
76 (psw *js-string-delimiter
*)
77 (loop for char across string
78 for code
= (char-code char
)
79 for special
= (lisp-special-char-to-js char
)
80 do
(cond (special (psw #\\) (psw special
))
81 ((or (<= code
#x1f
) (>= code
#x80
)) (psw (format nil
"\\u~4,'0x" code
)))
83 (psw *js-string-delimiter
*)))
85 (defmethod ps-print ((number number
))
86 (psw (format nil
(if (integerp number
) "~S" "~F") number
)))
88 ;;; expression and operator precedence rules
90 (defun expression-precedence (expr)
93 ((js-slot-value js-aref
) (op-precedence (car expr
)))
94 (js-assign (op-precedence '=))
95 (js-expression-if (op-precedence 'js-expression-if
))
96 (unary-operator (op-precedence (second expr
)))
97 (operator (op-precedence (second expr
)))
101 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
102 (defparameter *op-precedence-hash
* (make-hash-table :test
'eq
))
104 (let ((precedence 1))
105 (dolist (ops '((new js-slot-value js-aref
)
106 (postfix++ postfix--
)
107 (delete void typeof
++ -- unary
+ unary- ~
!)
111 (< > <= >= js-instance-of in
)
119 (= *= /= %
= += -
= <<= >>= >>>= \
&\
= ^
= \|
= js-assign
)
122 (setf (gethash op
*op-precedence-hash
*) precedence
))
125 (defun op-precedence (op)
126 (gethash op
*op-precedence-hash
*)))
128 (defprinter ps-quote
(val)
131 (error "Cannot translate quoted value ~S to javascript" val
)))
133 (defprinter js-literal
(str)
136 (defun print-comma-delimited-list (ps-forms)
137 (loop for
(form . remaining
) on ps-forms do
138 (ps-print form
) (when remaining
(psw ", "))))
140 (defprinter array-literal
(&rest initial-contents
)
141 (psw #\
[) (print-comma-delimited-list initial-contents
) (psw #\
]))
143 (defprinter js-aref
(array indices
)
144 (if (>= (expression-precedence array
) #.
(op-precedence 'js-aref
))
145 (parenthesize-print array
)
147 (loop for idx in indices do
148 (psw #\
[) (ps-print idx
) (psw #\
])))
150 (defprinter js-variable
(var)
151 (psw (js-translate-symbol var
)))
153 ;;; arithmetic operators
154 (defun parenthesize-print (ps-form)
155 (psw #\
() (ps-print ps-form
) (psw #\
)))
157 (defprinter operator
(op args
)
158 (loop for
(arg . remaining
) on args
159 with precedence
= (op-precedence op
) do
160 (if (>= (expression-precedence arg
) precedence
)
161 (parenthesize-print arg
)
163 (when remaining
(psw (format nil
" ~(~A~) " op
)))))
165 (defprinter unary-operator
(op arg
&key prefix space
)
166 (when prefix
(psw (format nil
"~(~a~)~:[~; ~]" op space
)))
167 (if (> (expression-precedence arg
)
168 (op-precedence (case op
172 (parenthesize-print arg
)
174 (unless prefix
(psw (format nil
"~(~a~)" op
))))
176 (defprinter js-funcall
(fun-designator args
)
177 (funcall (if (member (car fun-designator
) '(js-variable js-aref js-slot-value js-funcall
))
179 #'parenthesize-print
)
181 (psw #\
() (print-comma-delimited-list args
) (psw #\
)))
183 (defprinter js-block
(block-type statements
)
187 (incf *indent-level
*)
188 (dolist (statement statements
)
189 (newline-and-indent) (ps-print statement
) (psw #\
;))
190 (decf *indent-level
*)
195 (loop for
(statement . remaining
) on statements do
196 (ps-print statement
) (when remaining
(psw ", ")))
199 (defprinter js-lambda
(args body
)
200 (print-fun-def nil args body
))
202 (defprinter js-defun
(name args body
)
203 (print-fun-def name args body
))
205 (defun print-fun-def (name args body-block
)
206 (psw (format nil
"function ~:[~;~A~](" name
(js-translate-symbol name
)))
207 (loop for
(arg . remaining
) on args do
208 (psw (js-translate-symbol arg
)) (when remaining
(psw ", ")))
210 (ps-print body-block
))
212 (defprinter js-object
(slot-defs)
214 (loop for
((slot-name . slot-value
) . remaining
) on slot-defs do
215 (if (and (listp slot-name
) (eql 'ps-quote
(car slot-name
)) (symbolp (second slot-name
)))
216 (psw (js-translate-symbol (second slot-name
)))
217 (ps-print slot-name
))
219 (ps-print slot-value
)
220 (when remaining
(psw ", ")))
223 (defprinter js-slot-value
(obj slot
)
224 (if (or (> (expression-precedence obj
) #.
(op-precedence 'js-slot-value
))
226 (and (listp obj
) (member (car obj
) '(js-lambda js-object
))))
227 (parenthesize-print obj
)
229 (if (and (listp slot
) (eql 'ps-quote
(car slot
)))
231 (if (symbolp (second slot
))
232 (psw (js-translate-symbol (second slot
)))
234 (progn (psw #\
[) (ps-print slot
) (psw #\
]))))
236 (defprinter js-cond-statement
(clauses)
237 (loop for
(test body-block
) in clauses
238 for start
= "if (" then
" else if (" do
239 (if (equalp test
"true")
244 (ps-print body-block
)))
246 (defprinter js-statement-if
(test then-block else-block
)
247 (psw "if (") (ps-print test
) (psw ") ")
248 (ps-print then-block
)
251 (ps-print else-block
)))
253 (defprinter js-expression-if
(test then else
)
256 (if (>= (expression-precedence then
) (op-precedence 'js-expression-if
))
257 (parenthesize-print then
)
260 (if (>= (expression-precedence else
) (op-precedence 'js-expression-if
))
261 (parenthesize-print else
)
264 (defprinter js-assign
(lhs rhs
)
265 (ps-print lhs
) (psw " = ") (ps-print rhs
))
267 (defprinter js-var
(var-name &rest var-value
)
269 (psw (js-translate-symbol var-name
))
272 (ps-print (car var-value
))))
274 (defprinter js-break
(&optional label
)
278 (psw (js-translate-symbol label
))))
280 (defprinter js-continue
(&optional label
)
284 (psw (js-translate-symbol label
))))
287 (defprinter js-for
(label vars tests steps body-block
)
288 (when label
(psw (js-translate-symbol label
)) (psw ": ") (newline-and-indent))
290 (loop for
((var-name . var-init
) . remaining
) on vars
291 for decl
= "var " then
"" do
292 (psw decl
) (psw (js-translate-symbol var-name
)) (psw " = ") (ps-print var-init
) (when remaining
(psw ", ")))
294 (loop for
(test . remaining
) on tests do
295 (ps-print test
) (when remaining
(psw ", ")))
297 (loop for
(step . remaining
) on steps do
298 (ps-print step
) (when remaining
(psw ", ")))
300 (ps-print body-block
))
302 (defprinter js-for-in
(var object body-block
)
303 (psw "for (") (ps-print var
) (psw " in ")
304 (if (> (expression-precedence object
) (op-precedence 'in
))
305 (parenthesize-print object
)
308 (ps-print body-block
))
310 (defprinter js-while
(test body-block
)
311 (psw "while (") (ps-print test
) (psw ") ")
312 (ps-print body-block
))
314 (defprinter js-with
(expression body-block
)
315 (psw "with (") (ps-print expression
) (psw ") ")
316 (ps-print body-block
))
318 (defprinter js-switch
(test clauses
)
319 (flet ((print-body-statements (body-statements)
320 (incf *indent-level
*)
321 (loop for statement in body-statements do
322 (progn (newline-and-indent)
325 (decf *indent-level
*)))
326 (psw "switch (") (ps-print test
) (psw ") {")
327 (loop for
(val . statements
) in clauses
328 do
(progn (newline-and-indent)
329 (if (eq val
'default
)
330 (progn (psw "default: ")
331 (print-body-statements statements
))
335 (print-body-statements statements
)))))
339 (defprinter js-try
(body-block &key catch finally
)
341 (ps-print body-block
)
343 (psw " catch (") (psw (js-translate-symbol (first catch
))) (psw ") ")
344 (ps-print (second catch
)))
350 (defprinter js-regex
(regex)
351 (flet ((first-slash-p (string)
352 (and (> (length string
) 0) (char= (char string
0) #\
/))))
353 (let ((slash (unless (first-slash-p regex
) "/")))
354 (psw (format nil
(concatenate 'string slash
"~A" slash
) regex
)))))
356 ;;; conditional compilation
357 (defprinter cc-if
(test body-forms
)
360 (incf *indent-level
*)
361 (dolist (form body-forms
)
362 (newline-and-indent) (ps-print form
) (psw #\
;))
363 (decf *indent-level
*)
367 (defprinter js-instanceof
(value type
)
369 (if (> (expression-precedence value
) (op-precedence 'js-instance-of
))
370 (parenthesize-print value
)
373 (if (> (expression-precedence type
) (op-precedence 'js-instance-of
))
374 (parenthesize-print type
)
378 (defprinter js-escape
(lisp-form)
379 (psw `(ps1* ,lisp-form
)))
382 (macrolet ((def-stmt-printer (&rest stmts
)
383 `(progn ,@(mapcar (lambda (stmt)
384 `(defprinter ,(intern (format nil
"JS-~a" stmt
)) (expr)
385 (psw (format nil
"~(~a~) " ',stmt
))
388 (def-stmt-printer throw return
))