Commit | Line | Data |
---|---|---|
4a987e2b | 1 | (in-package :parenscript) |
9da682ca | 2 | |
839600e9 VS |
3 | (defvar *ps-output-stream*) |
4 | ||
5 | (defmethod parenscript-print (ps-form &optional *ps-output-stream*) | |
116f7450 | 6 | (setf *indent-level* 0) |
839600e9 VS |
7 | (flet ((print-ps (form) |
8 | (let ((*standard-output* *ps-output-stream*)) | |
116f7450 VS |
9 | (if (and (listp form) (eql 'js-block (car form))) ;; ignore top-level block |
10 | (dolist (statement (third form)) | |
11 | (ps-print statement) | |
12 | (format *ps-output-stream* ";~%")) | |
13 | (ps-print form))))) | |
839600e9 VS |
14 | (if *ps-output-stream* |
15 | (print-ps ps-form) | |
16 | (with-output-to-string (*ps-output-stream*) | |
17 | (print-ps ps-form))))) | |
18 | ||
19 | (defgeneric ps-print% (special-form-name special-form-args)) | |
9da682ca | 20 | |
4a987e2b VS |
21 | (defmacro defprinter (special-form content-args &body body) |
22 | "Given a special-form name and a destructuring lambda-list for its | |
23 | arguments, defines a printer for that form using the given body." | |
24 | (let ((sf (gensym)) | |
25 | (sf-args (gensym))) | |
839600e9 | 26 | `(defmethod ps-print% ((,sf (eql ',special-form)) ,sf-args) |
4a987e2b VS |
27 | (declare (ignore ,sf)) |
28 | (destructuring-bind ,content-args | |
29 | ,sf-args | |
30 | ,@body)))) | |
31 | ||
839600e9 | 32 | (defgeneric ps-print (compiled-form)) |
4a987e2b | 33 | |
53a1beac VS |
34 | (defmethod ps-print ((form null)) ;; don't print nils (ex: result of defining macros, etc.) |
35 | ) | |
36 | ||
839600e9 | 37 | (defmethod ps-print ((compiled-form cons)) |
4a987e2b VS |
38 | "Prints the given compiled ParenScript form starting at the given |
39 | indent position." | |
839600e9 | 40 | (ps-print% (car compiled-form) (cdr compiled-form))) |
4a987e2b | 41 | |
116f7450 VS |
42 | ;;; indenter |
43 | ||
44 | (defparameter *indent-level* 0) | |
45 | (defparameter *indent-num-space* 4) | |
46 | ||
47 | (defun newline-and-indent () | |
48 | (when (fresh-line) | |
49 | (loop repeat (* *indent-level* *indent-num-space*) | |
50 | do (write-char #\Space)))) | |
51 | ||
4a987e2b VS |
52 | ;;; string literals |
53 | (defvar *js-quote-char* #\' | |
54 | "Specifies which character JS should use for delimiting strings. | |
55 | ||
56 | This variable is useful when have to embed some javascript code | |
57 | in an html attribute delimited by #\\\" as opposed to #\\', or | |
58 | vice-versa.") | |
59 | ||
60 | (defparameter *js-lisp-escaped-chars* | |
61 | '((#\' . #\') | |
62 | (#\\ . #\\) | |
63 | (#\b . #\Backspace) | |
64 | (#\f . #.(code-char 12)) | |
65 | (#\n . #\Newline) | |
66 | (#\r . #\Return) | |
67 | (#\t . #\Tab))) | |
68 | ||
839600e9 | 69 | (defmethod ps-print ((string string)) |
4a987e2b VS |
70 | (flet ((lisp-special-char-to-js (lisp-char) |
71 | (car (rassoc lisp-char *js-lisp-escaped-chars*)))) | |
839600e9 VS |
72 | (write-char *js-quote-char*) |
73 | (loop for char across string | |
74 | for code = (char-code char) | |
75 | for special = (lisp-special-char-to-js char) | |
76 | do (cond (special (write-char #\\) | |
77 | (write-char special)) | |
78 | ((or (<= code #x1f) (>= code #x80)) | |
79 | (format *ps-output-stream* "\\u~4,'0x" code)) | |
80 | (t (write-char char))) | |
81 | finally (write-char *js-quote-char*)))) | |
82 | ||
83 | (defmethod ps-print ((number number)) | |
84 | (format *ps-output-stream* (if (integerp number) "~S" "~F") number)) | |
4a987e2b VS |
85 | |
86 | ;;; expression and operator precedence rules | |
87 | ||
88 | (defun expression-precedence (expr) | |
89 | (if (consp expr) | |
90 | (case (car expr) | |
4a987e2b VS |
91 | (js-expression-if (op-precedence 'js-expression-if)) |
92 | (js-assign (op-precedence '=)) | |
93 | (operator (op-precedence (second expr))) | |
94 | (otherwise 0)) | |
95 | 0)) | |
96 | ||
97 | (eval-when (:compile-toplevel :load-toplevel :execute) | |
98 | (defparameter *op-precedence-hash* (make-hash-table :test #'equal)) | |
99 | ||
100 | ;;; generate the operator precedences from *OP-PRECEDENCES* | |
101 | (let ((precedence 1)) | |
102 | (dolist (ops '((js-aref) | |
103 | (js-slot-value) | |
104 | (! not ~) | |
105 | (* / %) | |
106 | (+ -) | |
107 | (<< >>) | |
108 | (>>>) | |
109 | (< > <= >=) | |
110 | (in js-expression-if) | |
111 | (eql == != =) | |
112 | (=== !==) | |
113 | (&) | |
114 | (^) | |
115 | (\|) | |
116 | (\&\& and) | |
117 | (\|\| or) | |
118 | (js-assign *= /= %= += -= <<= >>= >>>= \&= ^= \|=) | |
119 | (comma))) | |
120 | (dolist (op ops) | |
121 | (let ((op-name (symbol-name op))) | |
122 | (setf (gethash op-name *op-precedence-hash*) precedence))) | |
123 | (incf precedence))) | |
124 | ||
125 | (defun op-precedence (op) | |
126 | (gethash (if (symbolp op) | |
127 | (symbol-name op) | |
128 | op) | |
129 | *op-precedence-hash*))) | |
9da682ca | 130 | |
4a987e2b VS |
131 | (defprinter script-quote (val) |
132 | (if (null val) | |
839600e9 | 133 | (write-string "null") |
4a987e2b | 134 | (error "Cannot translate quoted value ~S to javascript" val))) |
cc4f1551 | 135 | |
4a987e2b | 136 | (defprinter js-literal (str) |
839600e9 | 137 | (write-string str)) |
cc4f1551 | 138 | |
4a987e2b | 139 | (defprinter js-keyword (str) |
839600e9 | 140 | (write-string str)) |
46f794a4 | 141 | |
839600e9 VS |
142 | (defun print-comma-list (ps-forms) |
143 | (loop for (form . rest) on ps-forms | |
144 | with after = ", " | |
145 | unless rest do (setf after "") | |
146 | doing (progn (ps-print form) | |
147 | (write-string after)))) | |
cc4f1551 | 148 | |
4a987e2b | 149 | (defprinter array-literal (&rest initial-contents) |
839600e9 VS |
150 | (write-char #\[) |
151 | (print-comma-list initial-contents) | |
152 | (write-char #\])) | |
153 | ||
154 | (defprinter js-aref (array indices) | |
155 | (ps-print array) | |
156 | (loop for idx in indices do | |
157 | (progn (write-char #\[) | |
158 | (ps-print idx) | |
159 | (write-char #\])))) | |
160 | ||
161 | (defprinter object-literal (&rest slot-definitions) | |
162 | (write-char #\{) | |
163 | (loop for ((key . value) . rest) on slot-definitions | |
164 | with after = ", " | |
165 | unless rest do (setf after "") | |
166 | doing (progn (format *ps-output-stream* "~A: " (js-translate-symbol key)) | |
167 | (ps-print value) | |
168 | (write-string after))) | |
169 | (write-string " }")) | |
4a987e2b VS |
170 | |
171 | (defprinter js-variable (var) | |
839600e9 | 172 | (write-string (js-translate-symbol var))) |
cc4f1551 RD |
173 | |
174 | ;;; arithmetic operators | |
9da682ca | 175 | (defun script-convert-op-name (op) |
cc4f1551 RD |
176 | (case op |
177 | (and '\&\&) | |
178 | (or '\|\|) | |
179 | (not '!) | |
180 | (eql '\=\=) | |
181 | (= '\=\=) | |
182 | (t op))) | |
183 | ||
839600e9 VS |
184 | (defun parenthesize-print (ps-form) |
185 | (write-char #\() | |
186 | (ps-print ps-form) | |
187 | (write-char #\))) | |
cc4f1551 | 188 | |
4a987e2b | 189 | (defprinter operator (op args) |
839600e9 VS |
190 | (loop for (arg . rest) on args |
191 | with precedence = (op-precedence op) | |
192 | with op-string = (format nil " ~A " op) | |
193 | unless rest do (setf op-string "") | |
194 | do (progn (if (>= (expression-precedence arg) precedence) | |
195 | (parenthesize-print arg) | |
196 | (ps-print arg)) | |
197 | (write-string op-string)))) | |
4a987e2b VS |
198 | |
199 | (defprinter unary-operator (op arg &key prefix) | |
839600e9 VS |
200 | (when prefix |
201 | (write-string op)) | |
49c50da4 | 202 | (if (and (listp arg) (eql 'operator (car arg))) |
839600e9 VS |
203 | (parenthesize-print arg) |
204 | (ps-print arg)) | |
205 | (unless prefix | |
206 | (write-string op))) | |
4a987e2b VS |
207 | |
208 | ;;; function and method calls | |
209 | (defprinter js-funcall (fun-designator args) | |
839600e9 VS |
210 | (cond ((member (car fun-designator) '(js-variable js-aref js-slot-value)) |
211 | (ps-print fun-designator)) | |
212 | ((eql 'js-lambda (car fun-designator)) | |
213 | (write-char #\() | |
214 | (ps-print fun-designator) | |
215 | (write-char #\))) | |
216 | ((eql 'js-funcall (car fun-designator)) | |
217 | (ps-print fun-designator))) | |
218 | (write-char #\() | |
219 | (print-comma-list args) | |
220 | (write-char #\))) | |
4a987e2b VS |
221 | |
222 | (defprinter js-method-call (method object args) | |
839600e9 VS |
223 | ;; TODO: this may not be the best way to add ()'s around lambdas |
224 | ;; probably there is or should be a more general solution working | |
225 | ;; in other situations involving lambda's | |
116f7450 | 226 | (if (or (numberp object) (and (consp object) (member (car object) '(js-lambda js-object operator js-expression-if)))) |
839600e9 VS |
227 | (parenthesize-print object) |
228 | (ps-print object)) | |
229 | (write-string (js-translate-symbol method)) | |
230 | (write-char #\() | |
231 | (print-comma-list args) | |
232 | (write-char #\))) | |
cc4f1551 | 233 | |
4a987e2b | 234 | (defprinter js-block (statement-p statements) |
116f7450 VS |
235 | (if statement-p |
236 | (progn (write-char #\{) | |
237 | (incf *indent-level*) | |
238 | (loop for statement in statements | |
239 | do (progn (newline-and-indent) | |
240 | (ps-print statement) | |
241 | (write-char #\;))) | |
242 | (decf *indent-level*) | |
243 | (newline-and-indent) | |
244 | (write-char #\})) | |
245 | (progn (write-char #\() | |
246 | (loop for (statement . rest) on statements | |
247 | with after = ", " | |
248 | unless rest do (setf after "") | |
249 | do (progn (ps-print statement) | |
250 | (write-string after))) | |
251 | (write-char #\))))) | |
4a987e2b VS |
252 | |
253 | (defprinter js-lambda (args body) | |
839600e9 | 254 | (print-fun-def nil args body)) |
4a987e2b VS |
255 | |
256 | (defprinter js-defun (name args body) | |
839600e9 VS |
257 | (print-fun-def name args body)) |
258 | ||
116f7450 | 259 | (defun print-fun-def (name args body-block) |
839600e9 VS |
260 | (format *ps-output-stream* "function ~:[~;~A~](" name (js-translate-symbol name)) |
261 | (loop for (arg . rest) on args | |
262 | with after = ", " | |
263 | unless rest do (setf after "") | |
264 | do (progn (write-string (js-translate-symbol arg)) | |
265 | (write-string after)) | |
116f7450 VS |
266 | finally (write-string ") ")) |
267 | (ps-print body-block)) | |
cc4f1551 RD |
268 | |
269 | ;;; object creation | |
4a987e2b | 270 | (defprinter js-object (slot-defs) |
839600e9 VS |
271 | (write-string "{ ") |
272 | (loop for ((slot-name slot-value) . rest) on slot-defs | |
273 | with after = ", " | |
274 | unless rest do (setf after "") | |
275 | do (progn (if (and (listp slot-name) (eql 'script-quote (car slot-name)) (symbolp (second slot-name))) | |
276 | (write-string (js-translate-symbol (second slot-name))) | |
277 | (ps-print slot-name)) | |
278 | (write-string " : ") | |
279 | (ps-print slot-value) | |
280 | (write-string after))) | |
281 | (write-string " }")) | |
cc4f1551 | 282 | |
4a987e2b | 283 | (defprinter js-slot-value (obj slot) |
116f7450 | 284 | (if (and (listp obj) (member (car obj) '(js-expression-if))) |
839600e9 VS |
285 | (parenthesize-print obj) |
286 | (ps-print obj)) | |
287 | (if (and (listp slot) (eql 'script-quote (car slot))) | |
288 | (progn (write-char #\.) | |
289 | (if (symbolp (second slot)) | |
290 | (write-string (js-translate-symbol (second slot))) | |
291 | (ps-print slot))) | |
292 | (progn (write-char #\[) | |
293 | (ps-print slot) | |
294 | (write-char #\])))) | |
cc4f1551 RD |
295 | |
296 | ;;; cond | |
0949f072 | 297 | (defprinter js-cond-statement (clauses) |
839600e9 | 298 | (loop for (test body-block) in clauses |
116f7450 | 299 | for start = "if (" then " else if (" |
b0f64e9b | 300 | do (progn (if (equalp test "true") |
116f7450 | 301 | (write-string " else ") |
b0f64e9b VS |
302 | (progn (write-string start) |
303 | (ps-print test) | |
116f7450 VS |
304 | (write-string ") "))) |
305 | (ps-print body-block)))) | |
4a987e2b | 306 | |
116f7450 | 307 | (defprinter js-statement-if (test then-block else-block) |
839600e9 VS |
308 | (write-string "if (") |
309 | (ps-print test) | |
116f7450 VS |
310 | (write-string ") ") |
311 | (ps-print then-block) | |
312 | (when else-block | |
313 | (write-string " else ") | |
314 | (ps-print else-block))) | |
4a987e2b VS |
315 | |
316 | (defprinter js-expression-if (test then else) | |
839600e9 VS |
317 | (ps-print test) |
318 | (write-string " ? ") | |
319 | (if (>= (expression-precedence then) (op-precedence 'js-expression-if)) | |
320 | (parenthesize-print then) | |
321 | (ps-print then)) | |
322 | (write-string " : ") | |
5705b542 VS |
323 | (if (>= (expression-precedence else) (op-precedence 'js-expression-if)) |
324 | (parenthesize-print else) | |
325 | (ps-print else))) | |
cc4f1551 | 326 | |
4a987e2b | 327 | (defprinter js-assign (lhs rhs) |
839600e9 VS |
328 | (ps-print lhs) |
329 | (write-string " = ") | |
330 | (ps-print rhs)) | |
cc4f1551 | 331 | |
4a987e2b | 332 | (defprinter js-defvar (var-name &rest var-value) |
839600e9 VS |
333 | (write-string "var ") |
334 | (write-string (js-translate-symbol var-name)) | |
335 | (when var-value | |
336 | (write-string " = ") | |
337 | (ps-print (car var-value)))) | |
cc4f1551 RD |
338 | |
339 | ;;; iteration | |
4a987e2b | 340 | (defprinter js-for (vars steps test body-block) |
839600e9 VS |
341 | (write-string "for (") |
342 | (loop for ((var-name . var-init) . rest) on vars | |
343 | for decl = "var " then "" | |
344 | with after = ", " | |
345 | unless rest do (setf after "") | |
346 | do (progn (write-string decl) | |
347 | (write-string (js-translate-symbol var-name)) | |
348 | (write-string " = ") | |
349 | (ps-print var-init) | |
350 | (write-string after))) | |
351 | (write-string "; ") | |
352 | (ps-print test) | |
353 | (write-string "; ") | |
354 | (loop for ((var-name . var-init) . rest) on vars | |
355 | for step in steps | |
356 | with after = ", " | |
357 | unless rest do (setf after "") | |
358 | do (progn (write-string (js-translate-symbol var-name)) | |
359 | (write-string " = ") | |
360 | (ps-print step) | |
361 | (write-string after))) | |
116f7450 VS |
362 | (write-string ") ") |
363 | (ps-print body-block)) | |
cc4f1551 | 364 | |
4a987e2b | 365 | (defprinter js-for-each (var object body-block) |
839600e9 VS |
366 | (write-string "for (var ") |
367 | (write-string (js-translate-symbol var)) | |
368 | (write-string " in ") | |
369 | (ps-print object) | |
116f7450 VS |
370 | (write-string ") ") |
371 | (ps-print body-block)) | |
cc4f1551 | 372 | |
4a987e2b | 373 | (defprinter js-while (test body-block) |
839600e9 VS |
374 | (write-string "while (") |
375 | (ps-print test) | |
116f7450 VS |
376 | (write-string ") ") |
377 | (ps-print body-block)) | |
4a987e2b VS |
378 | |
379 | (defprinter js-with (expression body-block) | |
839600e9 VS |
380 | (write-string "with (") |
381 | (ps-print expression) | |
116f7450 VS |
382 | (write-string ") ") |
383 | (ps-print body-block)) | |
4a987e2b VS |
384 | |
385 | (defprinter js-switch (test clauses) | |
116f7450 VS |
386 | (flet ((print-body-statements (body-statements) |
387 | (incf *indent-level*) | |
388 | (loop for statement in body-statements do | |
389 | (progn (newline-and-indent) | |
390 | (ps-print statement) | |
391 | (write-char #\;))) | |
392 | (decf *indent-level*))) | |
393 | (write-string "switch (") | |
394 | (ps-print test) | |
395 | (write-string ") {") | |
396 | (loop for (val body-block) in clauses | |
397 | for body-statements = (third body-block) | |
398 | do (progn (newline-and-indent) | |
399 | (if (eql val 'default) | |
400 | (progn (write-string "default: ") | |
401 | (print-body-statements body-statements)) | |
402 | (progn (write-string "case ") | |
403 | (ps-print val) | |
404 | (write-char #\:) | |
405 | (print-body-statements body-statements))))) | |
406 | (write-char #\}))) | |
407 | ||
408 | (defprinter js-try (body-block &key catch finally) | |
409 | (write-string "try ") | |
410 | (ps-print body-block) | |
839600e9 | 411 | (when catch |
116f7450 | 412 | (write-string " catch (") |
839600e9 | 413 | (write-string (js-translate-symbol (first catch))) |
116f7450 | 414 | (write-string ") ") |
839600e9 VS |
415 | (ps-print (second catch))) |
416 | (when finally | |
116f7450 VS |
417 | (write-string " finally ") |
418 | (ps-print finally))) | |
cc4f1551 RD |
419 | |
420 | ;;; regex | |
4a987e2b VS |
421 | (defprinter js-regex (regex) |
422 | (flet ((first-slash-p (string) | |
839600e9 | 423 | (and (> (length string) 0) (char= (char string 0) #\/)))) |
4a987e2b | 424 | (let ((slash (unless (first-slash-p regex) "/"))) |
839600e9 | 425 | (format *ps-output-stream* (concatenate 'string slash "~A" slash) regex)))) |
cc4f1551 | 426 | |
4a987e2b | 427 | (defprinter js-return (value) |
839600e9 VS |
428 | (write-sequence "return " *ps-output-stream*) |
429 | (ps-print value)) | |
cc4f1551 RD |
430 | |
431 | ;;; conditional compilation | |
4a987e2b | 432 | (defprinter cc-if (test body-forms) |
839600e9 VS |
433 | (write-string "/*@if ") |
434 | (ps-print test) | |
116f7450 | 435 | (incf *indent-level*) |
839600e9 | 436 | (dolist (form body-forms) |
116f7450 VS |
437 | (newline-and-indent) |
438 | (ps-print form) | |
439 | (write-char #\;)) | |
440 | (decf *indent-level*) | |
441 | (newline-and-indent) | |
839600e9 | 442 | (write-string "@end @*/")) |
cc4f1551 | 443 | |
4a987e2b | 444 | (defprinter js-instanceof (value type) |
839600e9 VS |
445 | (write-char #\() |
446 | (ps-print value) | |
447 | (write-string " instanceof ") | |
448 | (ps-print type) | |
449 | (write-char #\))) | |
4a987e2b VS |
450 | |
451 | (defprinter js-named-operator (op value) | |
839600e9 VS |
452 | (format *ps-output-stream* "~(~A~) " op) |
453 | (ps-print value)) |