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
*)
16 (defun parenscript-print (form immediate?
)
17 (declare (special immediate?
))
18 (let ((*indent-level
* 0)
19 (*psw-stream
* (if immediate?
21 (make-string-output-stream)))
22 (%psw-accumulator
()))
23 (declare (special %psw-accumulator
))
24 (if (and (listp form
) (eq 'js
:block
(car form
))) ; ignore top-level block
25 (loop for
(statement . remaining
) on
(cdr form
) do
26 (ps-print statement
) (psw #\
;) (when remaining (psw #\Newline)))
29 (reverse (cons (get-output-stream-string *psw-stream
*) %psw-accumulator
)))))
32 (declare (special %psw-accumulator immediate?
))
34 (string (write-string obj
*psw-stream
*))
35 (character (write-char obj
*psw-stream
*))
38 (write-string (eval obj
) *psw-stream
*)
39 (setf %psw-accumulator
41 (cons (get-output-stream-string *psw-stream
*)
42 %psw-accumulator
)))))))
44 (defgeneric ps-print%
(special-form-name special-form-args
))
46 (defmacro defprinter
(special-form content-args
&body body
)
47 "Given a special-form name and a destructuring lambda-list for its
48 arguments, defines a printer for that form using the given body."
51 `(defmethod ps-print%
((,sf
(eql ',special-form
)) ,sf-args
)
52 (declare (ignorable ,sf
))
53 (destructuring-bind ,content-args
57 (defgeneric ps-print
(compiled-form))
59 (defmethod ps-print ((form null
))) ; don't print top-level nils (ex: result of defining macros, etc.)
61 (defmethod ps-print ((s symbol
))
62 (assert (keywordp s
) nil
"~S is not a symbol" s
)
63 (ps-print (string-downcase s
)))
65 (defmethod ps-print ((compiled-form cons
))
66 (ps-print%
(car compiled-form
) (cdr compiled-form
)))
68 (defun newline-and-indent ()
70 (progn (psw #\Newline
)
71 (loop repeat
(* *indent-level
* *indent-num-spaces
*) do
(psw #\Space
)))
74 (defparameter *js-lisp-escaped-chars
*
78 (#\f .
#.
(code-char 12))
83 (defmethod ps-print ((string string
))
84 (flet ((lisp-special-char-to-js (lisp-char)
85 (car (rassoc lisp-char
*js-lisp-escaped-chars
*))))
86 (psw *js-string-delimiter
*)
87 (loop for char across string
88 for code
= (char-code char
)
89 for special
= (lisp-special-char-to-js char
)
90 do
(cond (special (psw #\\) (psw special
))
91 ((or (<= code
#x1f
) (>= code
#x80
)) (format *psw-stream
* "\\u~4,'0x" code
))
93 (psw *js-string-delimiter
*)))
95 (defmethod ps-print ((number number
))
96 (format *psw-stream
* (if (integerp number
) "~S" "~F") number
))
98 ;;; expression and operator precedence rules
100 (defun expression-precedence (expr)
103 ((js:slot-value js
:aref
) (op-precedence (car expr
)))
104 (js:= (op-precedence 'js
:=))
105 (js:?
(op-precedence 'js
:?
))
106 (js:unary-operator
(op-precedence (second expr
)))
107 (operator (op-precedence (second expr
)))
111 (defprinter js
:literal
(str)
114 (defun print-comma-delimited-list (ps-forms)
115 (loop for
(form . remaining
) on ps-forms do
116 (ps-print form
) (when remaining
(psw ", "))))
118 (defprinter js
:array
(&rest initial-contents
)
119 (psw #\
[) (print-comma-delimited-list initial-contents
) (psw #\
]))
121 (defprinter js
:aref
(array indices
)
122 (if (>= (expression-precedence array
) (op-precedence 'js
:aref
))
123 (parenthesize-print array
)
125 (loop for idx in indices do
126 (psw #\
[) (ps-print idx
) (psw #\
])))
128 (defvar *lexical-bindings
* nil
)
130 (defun rename-js-variable (name)
131 (or (cdr (assoc name
*lexical-bindings
*))
134 (defprinter js
:let
(variables expression
)
135 (let ((*lexical-bindings
*
136 (append (mapcar (lambda (var)
137 (cons var
(if (assoc var
*lexical-bindings
*)
141 (ps-print expression
)))
143 (defprinter js
:variable
(var)
144 (psw (symbol-to-js-string (rename-js-variable var
))))
146 ;;; arithmetic operators
147 (defun parenthesize-print (ps-form)
148 (psw #\
() (ps-print ps-form
) (psw #\
)))
150 (defprinter js
:operator
(op &rest args
)
151 (loop for
(arg . remaining
) on args
152 with precedence
= (op-precedence op
) do
153 (if (>= (expression-precedence arg
) precedence
)
154 (parenthesize-print arg
)
156 (when remaining
(format *psw-stream
* " ~(~A~) " op
))))
158 (defprinter js
:unary-operator
(op arg
&key prefix space
)
159 (when prefix
(format *psw-stream
* "~(~a~)~:[~; ~]" op space
))
160 (if (> (expression-precedence arg
)
161 (op-precedence (case op
165 (parenthesize-print arg
)
167 (unless prefix
(format *psw-stream
* "~(~a~)" op
)))
169 (defprinter js
:funcall
(fun-designator &rest args
)
170 (funcall (if (member (car fun-designator
) '(js:variable js
:aref js
:slot-value js
:funcall
))
172 #'parenthesize-print
)
174 (psw #\
() (print-comma-delimited-list args
) (psw #\
)))
176 (defprinter js
:|
,|
(&rest expressions
)
178 (loop for
(exp . remaining
) on expressions do
179 (ps-print exp
) (when remaining
(psw ", ")))
182 (defprinter js
:block
(&rest statements
)
184 (incf *indent-level
*)
185 (dolist (statement statements
)
186 (newline-and-indent) (ps-print statement
) (psw #\
;))
187 (decf *indent-level
*)
191 (defprinter js
:lambda
(args body
)
192 (print-fun-def nil args body
))
194 (defprinter js
:defun
(name args body
)
195 (print-fun-def name args body
))
197 (defun print-fun-def (name args body-block
)
198 (format *psw-stream
* "function ~:[~;~A~](" name
(symbol-to-js-string name
))
199 (loop for
(arg . remaining
) on args do
200 (psw (symbol-to-js-string arg
)) (when remaining
(psw ", ")))
202 (ps-print body-block
))
204 (defprinter js
:object
(&rest slot-defs
)
206 (loop for
((slot-name . slot-value
) . remaining
) on slot-defs do
207 (ps-print slot-name
) (psw " : ") (ps-print slot-value
)
208 (when remaining
(psw ", ")))
211 (defprinter js
:slot-value
(obj slot
)
212 (if (or (> (expression-precedence obj
) (op-precedence 'js
:slot-value
))
214 (and (listp obj
) (member (car obj
) '(js:lambda js
:object
))))
215 (parenthesize-print obj
)
217 (if (and (symbolp slot
) (not (keywordp slot
)))
218 (progn (psw #\.
) (psw (symbol-to-js-string slot
)))
219 (progn (psw #\
[) (ps-print slot
) (psw #\
]))))
221 (defprinter js
:if
(test consequent
&rest clauses
)
222 (psw "if (") (ps-print test
) (psw ") ")
223 (ps-print consequent
)
224 (loop while clauses do
226 (:else-if
(psw " else if (") (ps-print (cadr clauses
)) (psw ") ")
227 (ps-print (caddr clauses
))
228 (setf clauses
(cdddr clauses
)))
229 (:else
(psw " else ")
230 (ps-print (cadr clauses
))
233 (defprinter js
:?
(test then else
)
234 (if (>= (expression-precedence test
) (op-precedence 'js
:?
))
235 (parenthesize-print test
)
238 (if (>= (expression-precedence then
) (op-precedence 'js
:?
))
239 (parenthesize-print then
)
242 (if (>= (expression-precedence else
) (op-precedence 'js
:?
))
243 (parenthesize-print else
)
246 (defprinter js
:= (lhs rhs
)
247 (ps-print lhs
) (psw " = ") (ps-print rhs
))
249 (defprinter js
:var
(var-name &rest var-value
)
254 (ps-print (car var-value
))))
256 (defprinter js
:break
(&optional label
)
260 (psw (symbol-to-js-string label
))))
262 (defprinter js
:continue
(&optional label
)
266 (psw (symbol-to-js-string label
))))
269 (defprinter js
:for
(label vars tests steps body-block
)
270 (when label
(psw (symbol-to-js-string label
)) (psw ": ") (newline-and-indent))
272 (loop for
((var-name . var-init
) . remaining
) on vars
273 for decl
= "var " then
"" do
274 (psw decl
) (psw (symbol-to-js-string var-name
)) (psw " = ") (ps-print var-init
) (when remaining
(psw ", ")))
276 (loop for
(test . remaining
) on tests do
277 (ps-print test
) (when remaining
(psw ", ")))
279 (loop for
(step . remaining
) on steps do
280 (ps-print step
) (when remaining
(psw ", ")))
282 (ps-print body-block
))
284 (defprinter js
:for-in
(var object body-block
)
285 (psw "for (var ") (ps-print var
) (psw " in ")
286 (if (> (expression-precedence object
) (op-precedence 'in
))
287 (parenthesize-print object
)
290 (ps-print body-block
))
292 (defprinter js
:while
(test body-block
)
293 (psw "while (") (ps-print test
) (psw ") ")
294 (ps-print body-block
))
296 (defprinter js
:with
(expression body-block
)
297 (psw "with (") (ps-print expression
) (psw ") ")
298 (ps-print body-block
))
300 (defprinter js
:switch
(test clauses
)
301 (flet ((print-body-statements (body-statements)
302 (incf *indent-level
*)
303 (loop for statement in body-statements do
304 (progn (newline-and-indent)
307 (decf *indent-level
*)))
308 (psw "switch (") (ps-print test
) (psw ") {")
309 (loop for
(val . statements
) in clauses
310 do
(progn (newline-and-indent)
311 (if (eq val
'default
)
312 (progn (psw "default: ")
313 (print-body-statements statements
))
317 (print-body-statements statements
)))))
321 (defprinter js
:try
(body-block &key catch finally
)
323 (ps-print body-block
)
325 (psw " catch (") (psw (symbol-to-js-string (first catch
))) (psw ") ")
326 (ps-print (second catch
)))
332 (defprinter js
:regex
(regex)
333 (let ((slash (unless (and (> (length regex
) 0) (char= (char regex
0) #\
/)) "/")))
334 (psw (concatenate 'string slash regex slash
))))
336 ;;; conditional compilation
337 (defprinter js
:cc-if
(test &rest body
)
340 (incf *indent-level
*)
342 (newline-and-indent) (ps-print form
) (psw #\
;))
343 (decf *indent-level
*)
347 (defprinter js
:instanceof
(value type
)
349 (if (> (expression-precedence value
) (op-precedence 'js
:instanceof
))
350 (parenthesize-print value
)
353 (if (> (expression-precedence type
) (op-precedence 'js
:instanceof
))
354 (parenthesize-print type
)
358 (defprinter js
:escape
(literal-js)
359 ;; literal-js should be a form that evaluates to a string containing valid JavaScript
363 (defprinter js
:throw
(x)
364 (psw "throw ") (ps-print x
))
366 (defprinter js
:return
(x)
367 (psw "return ") (ps-print x
))