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