js-translation.lisp 14.2 KB
Newer Older
1
(in-package :parenscript)
Red Daly's avatar
Red Daly committed
2

3
4
5
(defvar *ps-output-stream*)

(defmethod parenscript-print (ps-form &optional *ps-output-stream*)
6
  (setf *indent-level* 0)
7
8
  (flet ((print-ps (form)
           (let ((*standard-output* *ps-output-stream*))
9
10
11
12
13
             (if (and (listp form) (eql 'js-block (car form))) ;; ignore top-level block
                 (dolist (statement (third form))
                   (ps-print statement)
                   (format *ps-output-stream* ";~%"))
                 (ps-print form)))))
14
15
16
17
18
19
    (if *ps-output-stream*
        (print-ps ps-form)
        (with-output-to-string (*ps-output-stream*)
          (print-ps ps-form)))))

(defgeneric ps-print% (special-form-name special-form-args))
Red Daly's avatar
Red Daly committed
20

21
22
23
24
25
(defmacro defprinter (special-form content-args &body body)
  "Given a special-form name and a destructuring lambda-list for its
arguments, defines a printer for that form using the given body."
  (let ((sf (gensym))
        (sf-args (gensym)))
26
    `(defmethod ps-print% ((,sf (eql ',special-form)) ,sf-args)
27
28
29
30
31
      (declare (ignore ,sf))
      (destructuring-bind ,content-args
          ,sf-args
        ,@body))))

32
(defgeneric ps-print (compiled-form))
33

34
35
36
(defmethod ps-print ((form null)) ;; don't print nils (ex: result of defining macros, etc.)
  )

37
(defmethod ps-print ((compiled-form cons))
38
39
  "Prints the given compiled ParenScript form starting at the given
indent position."
40
  (ps-print% (car compiled-form) (cdr compiled-form)))
41

42
43
44
45
46
47
48
49
50
51
;;; indenter

(defparameter *indent-level* 0)
(defparameter *indent-num-space* 4)

(defun newline-and-indent ()
  (when (fresh-line)
    (loop repeat (* *indent-level* *indent-num-space*)
          do (write-char #\Space))))

52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
;;; string literals
(defvar *js-quote-char* #\'
  "Specifies which character JS should use for delimiting strings.

This variable is useful when have to embed some javascript code
in an html attribute delimited by #\\\" as opposed to #\\', or
vice-versa.")

(defparameter *js-lisp-escaped-chars*
  '((#\' . #\')
    (#\\ . #\\)
    (#\b . #\Backspace)
    (#\f . #.(code-char 12))
    (#\n . #\Newline)
    (#\r . #\Return)
    (#\t . #\Tab)))

69
(defmethod ps-print ((string string))
70
71
  (flet ((lisp-special-char-to-js (lisp-char)
           (car (rassoc lisp-char *js-lisp-escaped-chars*))))
72
73
74
75
76
77
78
79
80
81
82
83
84
    (write-char *js-quote-char*)
    (loop for char across string
          for code = (char-code char)
          for special = (lisp-special-char-to-js char)
          do (cond (special (write-char #\\)
                            (write-char special))
                   ((or (<= code #x1f) (>= code #x80))
                    (format *ps-output-stream* "\\u~4,'0x" code))
                   (t (write-char char)))
          finally (write-char *js-quote-char*))))

(defmethod ps-print ((number number))
  (format *ps-output-stream* (if (integerp number) "~S" "~F") number))
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129

;;; expression and operator precedence rules

(defun expression-precedence (expr)
  (if (consp expr)
      (case (car expr)
        (js-expression-if (op-precedence 'js-expression-if))
        (js-assign (op-precedence '=))
        (operator (op-precedence (second expr)))
        (otherwise 0))
      0))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defparameter *op-precedence-hash* (make-hash-table :test #'equal))

  ;;; generate the operator precedences from *OP-PRECEDENCES*
  (let ((precedence 1))
    (dolist (ops '((js-aref)
                   (js-slot-value)
                   (! not ~)
                   (* / %)
                   (+ -)
                   (<< >>)
                   (>>>)
                   (< > <= >=)
                   (in js-expression-if)
                   (eql == != =)
                   (=== !==)
                   (&)
                   (^)
                   (\|)
                   (\&\& and)
                   (\|\| or)
                   (js-assign *= /= %= += -= <<= >>= >>>= \&= ^= \|=)
                   (comma)))
      (dolist (op ops)
        (let ((op-name (symbol-name op)))
          (setf (gethash op-name *op-precedence-hash*) precedence)))
      (incf precedence)))

  (defun op-precedence (op)
    (gethash (if (symbolp op)
                 (symbol-name op)
                 op)
             *op-precedence-hash*)))
Red Daly's avatar
Red Daly committed
130

131
132
(defprinter script-quote (val)
  (if (null val)
133
      (write-string "null")
134
      (error "Cannot translate quoted value ~S to javascript" val)))
Red Daly's avatar
Red Daly committed
135

136
(defprinter js-literal (str)
137
  (write-string str))
Red Daly's avatar
Red Daly committed
138

139
(defprinter js-keyword (str)
140
  (write-string str))
141

142
143
144
145
146
147
(defun print-comma-list (ps-forms)
  (loop for (form . rest) on ps-forms
        with after = ", "
        unless rest do (setf after "")
        doing (progn (ps-print form)
                     (write-string after))))
Red Daly's avatar
Red Daly committed
148

149
(defprinter array-literal (&rest initial-contents)
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
  (write-char #\[)
  (print-comma-list initial-contents)
  (write-char #\]))

(defprinter js-aref (array indices)
  (ps-print array)
  (loop for idx in indices do
        (progn (write-char #\[)
               (ps-print idx)
               (write-char #\]))))

(defprinter object-literal (&rest slot-definitions)
  (write-char #\{)
  (loop for ((key . value) . rest) on slot-definitions
        with after = ", "
        unless rest do (setf after "")
        doing (progn (format *ps-output-stream* "~A: " (js-translate-symbol key))
                     (ps-print value)
                     (write-string after)))
  (write-string " }"))
170
171

(defprinter js-variable (var)
172
  (write-string (js-translate-symbol var)))
Red Daly's avatar
Red Daly committed
173
174

;;; arithmetic operators
Red Daly's avatar
Red Daly committed
175
(defun script-convert-op-name (op)
Red Daly's avatar
Red Daly committed
176
177
178
179
180
181
182
183
  (case op
    (and '\&\&)
    (or '\|\|)
    (not '!)
    (eql '\=\=)
    (=   '\=\=)
    (t op)))

184
185
186
187
(defun parenthesize-print (ps-form)
  (write-char #\()
  (ps-print ps-form)
  (write-char #\)))
Red Daly's avatar
Red Daly committed
188

189
(defprinter operator (op args)
190
191
192
193
194
195
196
197
  (loop for (arg . rest) on args
        with precedence = (op-precedence op)
        with op-string = (format nil " ~A " op)
        unless rest do (setf op-string "")
        do (progn (if (>= (expression-precedence arg) precedence)
                      (parenthesize-print arg)
                      (ps-print arg))
                  (write-string op-string))))
198
199

(defprinter unary-operator (op arg &key prefix)
200
201
  (when prefix
    (write-string op))
202
  (if (and (listp arg) (eql 'operator (car arg)))
203
204
205
206
      (parenthesize-print arg)
      (ps-print arg))
  (unless prefix
    (write-string op)))
207
208
209

;;; function and method calls
(defprinter js-funcall (fun-designator args)
210
211
212
213
214
215
216
217
218
219
220
  (cond ((member (car fun-designator) '(js-variable js-aref js-slot-value))
         (ps-print fun-designator))
        ((eql 'js-lambda (car fun-designator))
         (write-char #\()
         (ps-print fun-designator)
         (write-char #\)))
        ((eql 'js-funcall (car fun-designator))
         (ps-print fun-designator)))
  (write-char #\()
  (print-comma-list args)
  (write-char #\)))
221
222

(defprinter js-method-call (method object args)
223
224
225
  ;; TODO: this may not be the best way to add ()'s around lambdas
  ;; probably there is or should be a more general solution working
  ;; in other situations involving lambda's
226
  (if (or (numberp object) (and (consp object) (member (car object) '(js-lambda js-object operator js-expression-if))))
227
228
229
230
231
232
      (parenthesize-print object)
      (ps-print object))
  (write-string (js-translate-symbol method))
  (write-char #\()
  (print-comma-list args)
  (write-char #\)))
Red Daly's avatar
Red Daly committed
233

234
(defprinter js-block (statement-p statements)
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
  (if statement-p
      (progn (write-char #\{)
             (incf *indent-level*)
             (loop for statement in statements
                   do (progn (newline-and-indent)
                             (ps-print statement)
                             (write-char #\;)))
             (decf *indent-level*)
             (newline-and-indent)
             (write-char #\}))
      (progn (write-char #\()
             (loop for (statement . rest) on statements
                   with after = ", "
                   unless rest do (setf after "")
                   do (progn (ps-print statement)
                             (write-string after)))
             (write-char #\)))))
252
253

(defprinter js-lambda (args body)
254
  (print-fun-def nil args body))
255
256

(defprinter js-defun (name args body)
257
258
  (print-fun-def name args body))

259
(defun print-fun-def (name args body-block)
260
261
262
263
264
265
  (format *ps-output-stream* "function ~:[~;~A~](" name (js-translate-symbol name))
  (loop for (arg . rest) on args
        with after = ", "
        unless rest do (setf after "")
        do (progn (write-string (js-translate-symbol arg))
                  (write-string after))
266
267
        finally (write-string ") "))
  (ps-print body-block))
Red Daly's avatar
Red Daly committed
268
269

;;; object creation
270
(defprinter js-object (slot-defs)
271
272
273
274
275
276
277
278
279
280
281
  (write-string "{ ")
  (loop for ((slot-name slot-value) . rest) on slot-defs
        with after = ", "
        unless rest do (setf after "")
        do (progn (if (and (listp slot-name) (eql 'script-quote (car slot-name)) (symbolp (second slot-name)))
                      (write-string (js-translate-symbol (second slot-name)))
                      (ps-print slot-name))
                  (write-string " : ")
                  (ps-print slot-value)
                  (write-string after)))
  (write-string " }"))
Red Daly's avatar
Red Daly committed
282

283
(defprinter js-slot-value (obj slot)
284
  (if (and (listp obj) (member (car obj) '(js-expression-if)))
285
286
287
288
289
290
291
292
293
294
      (parenthesize-print obj)
      (ps-print obj))
  (if (and (listp slot) (eql 'script-quote (car slot)))
      (progn (write-char #\.)
             (if (symbolp (second slot))
                 (write-string (js-translate-symbol (second slot)))
                 (ps-print slot)))
      (progn (write-char #\[)
             (ps-print slot)
             (write-char #\]))))
Red Daly's avatar
Red Daly committed
295
296

;;; cond
297
(defprinter js-cond-statement (clauses)
298
  (loop for (test body-block) in clauses
299
        for start = "if (" then " else if ("
Vladimir Sedach's avatar
Vladimir Sedach committed
300
        do (progn (if (equalp test "true")
301
                      (write-string " else ")
Vladimir Sedach's avatar
Vladimir Sedach committed
302
303
                      (progn (write-string start)
                             (ps-print test)
304
305
                             (write-string ") ")))
                  (ps-print body-block))))
306

307
(defprinter js-statement-if (test then-block else-block)
308
309
  (write-string "if (")
  (ps-print test)
310
311
312
313
314
  (write-string ") ")
  (ps-print then-block)
  (when else-block
      (write-string " else ")
      (ps-print else-block)))
315
316

(defprinter js-expression-if (test then else)
317
318
319
320
321
322
  (ps-print test)
  (write-string " ? ")
  (if (>= (expression-precedence then) (op-precedence 'js-expression-if))
      (parenthesize-print then)
      (ps-print then))
  (write-string " : ")
323
324
325
  (if (>= (expression-precedence else) (op-precedence 'js-expression-if))
      (parenthesize-print else)
      (ps-print else)))
Red Daly's avatar
Red Daly committed
326

327
(defprinter js-assign (lhs rhs)
328
329
330
  (ps-print lhs)
  (write-string " = ")
  (ps-print rhs))
Red Daly's avatar
Red Daly committed
331

332
(defprinter js-defvar (var-name &rest var-value)
333
334
335
336
337
  (write-string "var ")
  (write-string (js-translate-symbol var-name))
  (when var-value
    (write-string " = ")
    (ps-print (car var-value))))
Red Daly's avatar
Red Daly committed
338
339

;;; iteration
340
(defprinter js-for (vars steps test body-block)
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
  (write-string "for (")
  (loop for ((var-name . var-init) . rest) on vars
        for decl = "var " then ""
        with after = ", "
        unless rest do (setf after "")
        do (progn (write-string decl)
                  (write-string (js-translate-symbol var-name))
                  (write-string " = ")
                  (ps-print var-init)
                  (write-string after)))
  (write-string "; ")
  (ps-print test)
  (write-string "; ")
  (loop for ((var-name . var-init) . rest) on vars
        for step in steps
        with after = ", "
        unless rest do (setf after "")
        do (progn (write-string (js-translate-symbol var-name))
                  (write-string " = ")
                  (ps-print step)
                  (write-string after)))
362
363
  (write-string ") ")
  (ps-print body-block))
Red Daly's avatar
Red Daly committed
364

365
(defprinter js-for-each (var object body-block)
366
367
368
369
  (write-string "for (var ")
  (write-string (js-translate-symbol var))
  (write-string " in ")
  (ps-print object)
370
371
  (write-string ") ")
  (ps-print body-block))
Red Daly's avatar
Red Daly committed
372

373
(defprinter js-while (test body-block)
374
375
  (write-string "while (")
  (ps-print test)
376
377
  (write-string ") ")
  (ps-print body-block))
378
379

(defprinter js-with (expression body-block)
380
381
  (write-string "with (")
  (ps-print expression)
382
383
  (write-string ") ")
  (ps-print body-block))
384
385

(defprinter js-switch (test clauses)
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
  (flet ((print-body-statements (body-statements)
           (incf *indent-level*)
           (loop for statement in body-statements do
                 (progn (newline-and-indent)
                        (ps-print statement)
                        (write-char #\;)))
           (decf *indent-level*)))
    (write-string "switch (")
    (ps-print test)
    (write-string ") {")
    (loop for (val body-block) in clauses
          for body-statements = (third body-block)
          do (progn (newline-and-indent)
                    (if (eql val 'default)
                        (progn (write-string "default: ")
                               (print-body-statements body-statements))
                        (progn (write-string "case ")
                               (ps-print val)
                               (write-char #\:)
                               (print-body-statements body-statements)))))
    (write-char #\})))

(defprinter js-try (body-block &key catch finally)
  (write-string "try ")
  (ps-print body-block)
411
  (when catch
412
    (write-string " catch (")
413
    (write-string (js-translate-symbol (first catch)))
414
    (write-string ") ")
415
416
    (ps-print (second catch)))
  (when finally
417
418
    (write-string " finally ")
    (ps-print finally)))
Red Daly's avatar
Red Daly committed
419
420

;;; regex
421
422
(defprinter js-regex (regex)
  (flet ((first-slash-p (string)
423
           (and (> (length string) 0) (char= (char string 0) #\/))))
424
    (let ((slash (unless (first-slash-p regex) "/")))
425
      (format *ps-output-stream* (concatenate 'string slash "~A" slash) regex))))
Red Daly's avatar
Red Daly committed
426

427
(defprinter js-return (value)
428
429
  (write-sequence "return " *ps-output-stream*)
  (ps-print value))
Red Daly's avatar
Red Daly committed
430
431

;;; conditional compilation
432
(defprinter cc-if (test body-forms)
433
434
  (write-string "/*@if ")
  (ps-print test)
435
  (incf *indent-level*)
436
  (dolist (form body-forms)
437
438
439
440
441
    (newline-and-indent)    
    (ps-print form)
    (write-char #\;))
  (decf *indent-level*)
  (newline-and-indent)
442
  (write-string "@end @*/"))
Red Daly's avatar
Red Daly committed
443

444
(defprinter js-instanceof (value type)
445
446
447
448
449
  (write-char #\()
  (ps-print value)
  (write-string " instanceof ")
  (ps-print type)
  (write-char #\)))
450
451

(defprinter js-named-operator (op value)
452
453
  (format *ps-output-stream* "~(~A~) " op)
  (ps-print value))