d81d239c5551e116460e759ad6d7e6e1beca133a
[clinton/parenscript.git] / src / js.lisp
1 (in-package :js)
2
3 ;;; ecmascript standard:
4 ;;; http://www.ecma-international.org/publications/standards/Ecma-262.htm
5
6 ;;; javascript name conversion
7
8 (defparameter *special-chars*
9 '((#\! . "Bang")
10 (#\? . "What")
11 (#\# . "Hash")
12 (#\@ . "At")
13 (#\% . "Percent")
14 (#\+ . "Plus")
15 (#\* . "Star")
16 (#\/ . "Slash")))
17
18 (defun string-chars (string)
19 (coerce string 'list))
20
21 (defun constant-string-p (string)
22 (let ((len (length string))
23 (constant-chars '(#\+ #\*)))
24 (and (> len 2)
25 (member (char string 0) constant-chars)
26 (member (char string (1- len)) constant-chars))))
27
28 (defun first-uppercase-p (string)
29 (and (> (length string) 1)
30 (member (char string 0) '(#\+ #\*))))
31
32 (defun untouchable-string-p (string)
33 (and (> (length string) 1)
34 (char= #\: (char string 0))))
35
36 (defun symbol-to-js (symbol)
37 (when (symbolp symbol)
38 (setf symbol (symbol-name symbol)))
39 (let ((symbols (string-split symbol '(#\.))))
40 (cond ((null symbols) "")
41 ((= (length symbols) 1)
42 (let (res
43 (do-not-touch nil)
44 (lowercase t)
45 (all-uppercase nil))
46 (cond ((constant-string-p symbol)
47 (setf all-uppercase t
48 symbol (subseq symbol 1 (1- (length symbol)))))
49 ((first-uppercase-p symbol)
50 (setf lowercase nil
51 symbol (subseq symbol 1)))
52 ((untouchable-string-p symbol)
53 (setf do-not-touch t
54 symbol (subseq symbol 1))))
55 (flet ((reschar (c)
56 (push (cond
57 (do-not-touch c)
58 ((and lowercase (not all-uppercase))
59 (char-downcase c))
60 (t (char-upcase c)))
61 res)
62 (setf lowercase t)))
63 (dotimes (i (length symbol))
64 (let ((c (char symbol i)))
65 (cond
66 ((eql c #\-)
67 (setf lowercase (not lowercase)))
68 ((assoc c *special-chars*)
69 (dolist (i (coerce (cdr (assoc c *special-chars*)) 'list))
70 (reschar i)))
71 (t (reschar c))))))
72 (coerce (nreverse res) 'string)))
73 (t (string-join (mapcar #'symbol-to-js symbols) ".")))))
74
75 ;;; js language types
76
77 (defmethod js-equal ((obj1 list) (obj2 list))
78 (and (= (length obj1) (length obj2))
79 (every #'js-equal obj1 obj2)))
80 (defmethod js-equal ((obj1 t) (obj2 t))
81 (equal obj1 obj2))
82
83 (defmacro defjsclass (name superclasses slots &rest class-options)
84 (let ((slot-names (mapcar #'(lambda (slot) (if (atom slot) slot (first slot))) slots)))
85 `(progn
86 (defclass ,name ,superclasses
87 ,slots ,@class-options)
88 (defmethod js-equal ((obj1 ,name) (obj2 ,name))
89 (every #'(lambda (slot)
90 (js-equal (slot-value obj1 slot)
91 (slot-value obj2 slot)))
92 ',slot-names)))))
93
94 (defjsclass statement ()
95 ((value :initarg :value :accessor value :initform nil)))
96
97 (defjsclass expression (statement)
98 ((value)))
99
100 ;;; indenter
101
102 (defun special-append-to-last (form elt)
103 (flet ((special-append (form elt)
104 (let ((len (length form)))
105 (if (and (> len 0)
106 (member (char form (1- len))
107 '(#\; #\, #\})))
108 form
109 (concatenate 'string form elt)))))
110 (cond ((stringp form)
111 (special-append form elt))
112 ((consp form)
113 (let ((last (last form)))
114 (if (stringp (car last))
115 (rplaca last (special-append (car last) elt))
116 (append-to-last (car last) elt))
117 form))
118 (t (error "unsupported form ~S" form)))))
119
120 (defun dwim-join (value-string-lists max-length
121 &key (start "")
122 end
123 (join-before "")
124 join-after
125 (white-space (make-string (length start) :initial-element #\Space))
126 (separator " ")
127 (append-to-last #'append-to-last)
128 (collect t))
129 #+nil
130 (format t "value-string-lists: ~S~%" value-string-lists)
131
132 ;;; collect single value-string-lists until line full
133
134 (do* ((string-lists value-string-lists (cdr string-lists))
135 (string-list (car string-lists) (car string-lists))
136 (cur-elt start)
137 (is-first t nil)
138 (cur-empty t)
139 (res nil))
140 ((null string-lists)
141 (unless cur-empty
142 (push cur-elt res))
143 (if (null res)
144 (list (concatenate 'string start end))
145 (progn
146 (when end
147 (setf (first res)
148 (funcall append-to-last (first res) end)))
149 (nreverse res))))
150 #+nil
151 (format t "string-list: ~S~%" string-list)
152
153 (when join-after
154 (unless (null (cdr string-lists))
155 (funcall append-to-last string-list join-after)))
156
157 (if (and collect (= (length string-list) 1))
158 (progn
159 #+nil
160 (format t "cur-elt: ~S line-length ~D, max-length ~D, string: ~S~%"
161 cur-elt
162 (+ (length (first string-list))
163 (length cur-elt))
164 max-length
165 (first string-list))
166 (if (or cur-empty
167 (< (+ (length (first string-list))
168 (length cur-elt)) max-length))
169 (setf cur-elt
170 (concatenate 'string cur-elt
171 (if (or is-first (and cur-empty (string= join-before "")))
172 "" (concatenate 'string separator join-before))
173 (first string-list))
174 cur-empty nil)
175 (progn
176 (push cur-elt res)
177 (setf cur-elt (concatenate 'string white-space
178 join-before (first string-list))
179 cur-empty nil))))
180
181 (progn
182 (unless cur-empty
183 (push cur-elt res)
184 (setf cur-elt white-space
185 cur-empty t))
186 (setf res (nconc (nreverse
187 (cons (concatenate 'string
188 cur-elt
189 (if (null res)
190 "" join-before)
191 (first string-list))
192 (mapcar #'(lambda (x) (concatenate 'string white-space x))
193 (cdr string-list))))
194 res))
195 (setf cur-elt white-space cur-empty t)))))
196
197 (defmethod js-to-strings ((expression expression) start-pos)
198 (declare (ignore start-pos))
199 (list (princ-to-string (value expression))))
200
201 (defmethod js-to-statement-strings ((expression expression) start-pos)
202 (js-to-strings expression start-pos))
203
204 (defmethod js-to-statement-strings ((statement statement) start-pos)
205 (declare (ignore start-pos))
206 (list (princ-to-string (value statement))))
207
208 ;;; compiler macros
209
210 (eval-when (:compile-toplevel :load-toplevel :execute)
211 (defvar *js-compiler-macros* (make-hash-table :test 'equal)
212 "*JS-COMPILER-MACROS* is a hash-table containing the functions corresponding
213 to javascript special forms, indexed by their name. Javascript special
214 forms are compiler macros for JS expressions."))
215
216 (defmacro define-js-compiler-macro (name lambda-list &rest body)
217 "Define a javascript compiler macro NAME. Arguments are destructured
218 according to LAMBDA-LIST. The resulting JS language types are appended
219 to the ongoing javascript compilation."
220 (let ((js-name (intern (concatenate 'string "JS-" (symbol-name name)) #.*package*)))
221 `(eval-when (:compile-toplevel :load-toplevel :execute)
222 (defun ,js-name ,lambda-list ,@body)
223 (setf (gethash ,(symbol-name name) *js-compiler-macros*) #',js-name))))
224
225 (defun undefine-js-compiler-macro (name)
226 (declare (type symbol name))
227 (when (gethash (symbol-name name) *js-compiler-macros*)
228 (warn "Redefining compiler macro ~S" name)
229 (remhash (symbol-name name) *js-compiler-macros*)))
230
231 (defun js-compiler-macro-form-p (form)
232 (when (and (symbolp (car form))
233 (gethash (symbol-name (car form)) *js-compiler-macros*))
234 t))
235
236 (defun js-get-compiler-macro (name)
237 (when (symbolp name)
238 (gethash (symbol-name name) *js-compiler-macros*)))
239
240 ;;; macro expansion
241
242 (eval-when (:compile-toplevel :load-toplevel :execute)
243 (defvar *js-macro-toplevel* (make-hash-table :test 'equal)
244 "Toplevel of macro expansion, holds all the toplevel javascript macros.")
245 (defvar *js-macro-env* (list *js-macro-toplevel*)
246 "Current macro environment."))
247
248 (defun lookup-macro (name)
249 "Lookup the macro NAME in the current macro expansion
250 environment. Returns the macro and the parent macro environment of
251 this macro."
252 (unless (symbolp name)
253 (return-from lookup-macro nil))
254 (do ((env *js-macro-env* (cdr env)))
255 ((null env) nil)
256 (let ((val (gethash (symbol-name name) (car env))))
257 (when val
258 (return-from lookup-macro
259 (values val (or (cdr env)
260 (list *js-macro-toplevel*))))))))
261
262 (defmacro defjsmacro (name args &rest body)
263 "Define a javascript macro, and store it in the toplevel macro environment."
264 (let ((lambda-list (gensym)))
265 (undefine-js-compiler-macro name)
266 `(setf (gethash ,(symbol-name name) *js-macro-toplevel*)
267 #'(lambda (&rest ,lambda-list)
268 (destructuring-bind ,args ,lambda-list ,@body)))))
269
270 (defun import-macros-from-lisp (&rest names)
271 "Import the named lisp macros into the js macro expansion"
272 (dolist (name names)
273 (undefine-js-compiler-macro name)
274 (setf (gethash (symbol-name name) *js-macro-toplevel*)
275 (lambda (&rest args)
276 (macroexpand `(,name ,@args))))))
277
278 (defun js-expand-form (expr)
279 "Expand a javascript form."
280 (cond ((atom expr)
281 (multiple-value-bind (js-macro macro-env)
282 (lookup-macro expr)
283 (if js-macro
284 (js-expand-form (let ((*js-macro-env* macro-env))
285 (funcall js-macro)))
286 expr)))
287
288 ((js-compiler-macro-form-p expr) expr)
289
290 ((equal (first expr) 'quote) expr)
291
292 (t (let ((js-macro (lookup-macro (car expr))))
293 (if js-macro
294 (js-expand-form (apply js-macro (cdr expr)))
295 expr)))))
296
297 (defvar *var-counter* 0)
298
299 (defun js-gensym (&optional (name "js"))
300 (intern (format nil "tmp-~A-~A" name (incf *var-counter*)) #.*package*))
301
302 ;;; literals
303
304 (defmacro defjsliteral (name string)
305 "Define a Javascript literal that will expand to STRING."
306 `(define-js-compiler-macro ,name () (make-instance 'expression :value ,string)))
307
308 (defjsliteral this "this")
309 (defjsliteral t "true")
310 (defjsliteral nil "null")
311 (defjsliteral false "false")
312 (defjsliteral undefined "undefined")
313
314 (defmacro defjskeyword (name string)
315 "Define a Javascript keyword that will expand to STRING."
316 `(define-js-compiler-macro ,name () (make-instance 'statement :value ,string)))
317
318 (defjskeyword break "break")
319 (defjskeyword continue "continue")
320
321 ;;; array literals
322
323 (defjsclass array-literal (expression)
324 ((values :initarg :values :accessor array-values)))
325
326 (define-js-compiler-macro array (&rest values)
327 (make-instance 'array-literal
328 :values (mapcar #'js-compile-to-expression values)))
329
330 (defjsmacro list (&rest values)
331 `(array ,@values))
332
333 (defmethod js-to-strings ((array array-literal) start-pos)
334 (let ((value-string-lists
335 (mapcar #'(lambda (x) (js-to-strings x (+ start-pos 2)))
336 (array-values array)))
337 (max-length (- 80 start-pos 2)))
338 (dwim-join value-string-lists max-length
339 :start "[ " :end " ]"
340 :join-after ",")))
341
342 (defjsclass js-aref (expression)
343 ((array :initarg :array
344 :accessor aref-array)
345 (index :initarg :index
346 :accessor aref-index)))
347
348 (define-js-compiler-macro aref (array &rest coords)
349 (make-instance 'js-aref
350 :array (js-compile-to-expression array)
351 :index (mapcar #'js-compile-to-expression coords)))
352
353 (defmethod js-to-strings ((aref js-aref) start-pos)
354 (dwim-join (cons (js-to-strings (aref-array aref) start-pos)
355 (mapcar #'(lambda (x) (dwim-join (list (js-to-strings x (+ start-pos 2)))
356 (- 80 start-pos 2)
357 :start "[" :end "]"))
358 (aref-index aref)))
359 (- 80 start-pos 2) :separator ""
360 :white-space " "))
361
362 (defjsmacro make-array (&rest inits)
363 `(new (*array ,@inits)))
364
365 ;;; object literals (maps and hash-tables)
366
367 (defjsclass object-literal (expression)
368 ((values :initarg :values :accessor object-values)))
369
370 (define-js-compiler-macro {} (&rest values)
371 (make-instance 'object-literal
372 :values (loop
373 for (key value) on values by #'cddr
374 collect (cons key (js-compile-to-expression value)))))
375
376 (defmethod js-to-strings ((obj object-literal) start-pos)
377 (dwim-join (loop
378 for (key . value) in (object-values obj)
379 append (list
380 (dwim-join (list (list (format nil "~A:" (symbol-to-js key)))
381 (js-to-strings value (+ start-pos 2)))
382 (- 80 start-pos 2)
383 :start "" :end "" :join-after "")))
384 (- 80 start-pos 2)
385 :start "{ " :end " }"
386 :join-after ","))
387
388 ;;; string literals
389
390 (defjsclass string-literal (expression)
391 (value))
392
393 (defvar *js-quote-char* #\'
394 "Specifies which character JS sholud use for delimiting strings.
395
396 This variable is usefull when have to embed some javascript code
397 in an html attribute delimited by #\\\" as opposed to #\\', or
398 vice-versa.")
399
400 (defmethod js-to-strings ((string string-literal) start-pos)
401 (declare (ignore start-pos)
402 (inline lisp-special-char-to-js))
403 (list (with-output-to-string (escaped)
404 (loop
405 initially (write-char *js-quote-char* escaped)
406 for char across (value string)
407 for code = (char-code char)
408 for special = (lisp-special-char-to-js char)
409 do
410 (cond
411 (special
412 (write-char #\\ escaped)
413 (write-char special escaped))
414 ((or (<= code #x1f) (>= code #x80))
415 (format escaped "\\u~4,'0x" code))
416 (t (write-char char escaped)))
417 finally (write-char *js-quote-char* escaped)))))
418
419 (defparameter *js-lisp-escaped-chars*
420 '((#\' . #\')
421 (#\\ . #\\)
422 (#\b . #\Backspace)
423 (#\f . #.(code-char 12))
424 (#\n . #\Newline)
425 (#\r . #\Return)
426 (#\t . #\Tab)))
427
428 (defun lisp-special-char-to-js(lisp-char)
429 (car (rassoc lisp-char *js-lisp-escaped-chars*)))
430
431 ;;; number literals
432
433 (defjsclass number-literal (expression)
434 (value))
435
436 ;;; variables
437
438 (defjsclass js-variable (expression)
439 (value))
440
441 (defmethod js-to-strings ((v js-variable) start-form)
442 (declare (ignore start-form))
443 (list (symbol-to-js (value v))))
444
445 ;;; arithmetic operators
446
447 (eval-when (:compile-toplevel :load-toplevel :execute)
448
449 (defparameter *op-precedence-hash* (make-hash-table))
450
451 (defparameter *op-precedences*
452 '((aref)
453 (slot-value)
454 (! not ~)
455 (* / %)
456 (+ -)
457 (<< >>)
458 (>>>)
459 (< > <= >=)
460 (in if)
461 (eql == != =)
462 (=== !==)
463 (&)
464 (^)
465 (\|)
466 (\&\& and)
467 (\|\| or)
468 (setf *= /= %= += -= <<= >>= >>>= \&= ^= \|=)
469 (comma)))
470
471 ;;; generate the operator precedences from *OP-PRECEDENCES*
472 (let ((precedence 1))
473 (dolist (ops *op-precedences*)
474 (dolist (op ops)
475 (setf (gethash op *op-precedence-hash*) precedence))
476 (incf precedence))))
477
478 (defun js-convert-op-name (op)
479 (case op
480 (and '\&\&)
481 (or '\|\|)
482 (not '!)
483 (eql '\=\=)
484 (= '\=\=)
485 (t op)))
486
487 (defjsclass op-form (expression)
488 ((operator :initarg :operator :accessor operator)
489 (args :initarg :args :accessor op-args)))
490
491 (defun op-form-p (form)
492 (and (listp form)
493 (not (js-compiler-macro-form-p form))
494 (not (null (gethash (first form) *op-precedence-hash*)))))
495
496 (defun klammer (string-list)
497 (prepend-to-first string-list "(")
498 (append-to-last string-list ")")
499 string-list)
500
501 (defmethod expression-precedence ((expression expression))
502 0)
503
504 (defmethod expression-precedence ((form op-form))
505 (gethash (operator form) *op-precedence-hash*))
506
507 (defmethod js-to-strings ((form op-form) start-pos)
508 (let* ((precedence (expression-precedence form))
509 (value-string-lists
510 (mapcar #'(lambda (x)
511 (let ((string-list (js-to-strings x (+ start-pos 2))))
512 (if (>= (expression-precedence x) precedence)
513 (klammer string-list)
514 string-list)))
515 (op-args form)))
516 (max-length (- 80 start-pos 2))
517 (op-string (format nil "~A " (operator form))))
518 (dwim-join value-string-lists max-length :join-before op-string)
519 ))
520
521 (defjsmacro 1- (form)
522 `(- ,form 1))
523
524 (defjsmacro 1+ (form)
525 `(+ ,form 1))
526
527 (defjsclass one-op (expression)
528 ((pre-p :initarg :pre-p
529 :initform nil
530 :accessor one-op-pre-p)
531 (op :initarg :op
532 :accessor one-op)))
533
534 (defmethod js-to-strings ((one-op one-op) start-pos)
535 (let* ((value (value one-op))
536 (value-strings (js-to-strings value start-pos)))
537 (when (typep value 'op-form)
538 (setf value-strings (klammer value-strings)))
539 (if (one-op-pre-p one-op)
540 (prepend-to-first value-strings
541 (one-op one-op))
542 (append-to-last value-strings
543 (one-op one-op)))))
544
545 (define-js-compiler-macro incf (x)
546 (make-instance 'one-op :pre-p t :op "++"
547 :value (js-compile-to-expression x)))
548 (define-js-compiler-macro ++ (x)
549 (make-instance 'one-op :pre-p nil :op "++"
550 :value (js-compile-to-expression x)))
551 (define-js-compiler-macro decf (x)
552 (make-instance 'one-op :pre-p t :op "--"
553 :value (js-compile-to-expression x)))
554 (define-js-compiler-macro -- (x)
555 (make-instance 'one-op :pre-p nil :op "--"
556 :value (js-compile-to-expression x)))
557
558
559 (define-js-compiler-macro not (x)
560 (let ((value (js-compile-to-expression x)))
561 (if (and (typep value 'op-form)
562 (= (length (op-args value)) 2))
563 (let ((new-op (case (operator value)
564 (== '!=)
565 (< '>=)
566 (> '<=)
567 (<= '>)
568 (>= '<)
569 (!= '==)
570 (=== '!==)
571 (!== '===)
572 (t nil))))
573 (if new-op
574 (make-instance 'op-form :operator new-op
575 :args (op-args value))
576 (make-instance 'one-op :pre-p t :op "!"
577 :value value)))
578 (make-instance 'one-op :pre-p t :op "!"
579 :value value))))
580
581 ;;; function calls
582
583 (defjsclass function-call (expression)
584 ((function :initarg :function :accessor f-function)
585 (args :initarg :args :accessor f-args)))
586
587 (defun funcall-form-p (form)
588 (and (listp form)
589 (not (op-form-p form))
590 (not (js-compiler-macro-form-p form))))
591
592 (defmethod js-to-strings ((form function-call) start-pos)
593 (let* ((value-string-lists
594 (mapcar #'(lambda (x) (js-to-strings x (+ start-pos 2)))
595 (f-args form)))
596 (max-length (- 80 start-pos 2))
597 (args (dwim-join value-string-lists max-length
598 :start "(" :end ")" :join-after ",")))
599 (etypecase (f-function form)
600 (js-lambda
601 (dwim-join (list (append (dwim-join (list (js-to-strings (f-function form) (+ start-pos 2)))
602 max-length
603 :start "(" :end ")" :separator "")
604 args))
605 max-length
606 :separator ""))
607 ((or js-variable js-aref js-slot-value)
608 (dwim-join (list (js-to-strings (f-function form) (+ start-pos 2))
609 args)
610 max-length
611 :separator "")))))
612
613 (defjsclass method-call (expression)
614 ((method :initarg :method :accessor m-method)
615 (object :initarg :object :accessor m-object)
616 (args :initarg :args :accessor m-args)))
617
618 (defmethod js-to-strings ((form method-call) start-pos)
619 (let ((fname (dwim-join (list (js-to-strings (m-object form) (+ start-pos 2))
620 (list (symbol-to-js (m-method form))))
621 (- 80 start-pos 2)
622 :end "("
623 :separator "")))
624 (let ((butlast (butlast fname))
625 (last (car (last fname))))
626 (nconc butlast
627 (dwim-join (mapcar #'(lambda (x) (js-to-strings x (+ start-pos 2)))
628 (m-args form))
629 (- 80 start-pos 2)
630 :start last
631 :end ")"
632 :join-after ",")))))
633
634 (defun method-call-p (form)
635 (and (funcall-form-p form)
636 (symbolp (first form))
637 (eql (char (symbol-name (first form)) 0) #\.)))
638
639 ;;; body forms
640
641 (defjsclass js-body (expression)
642 ((stmts :initarg :stmts :accessor b-stmts)
643 (indent :initarg :indent :initform "" :accessor b-indent)))
644
645 (define-js-compiler-macro progn (&rest body)
646 (make-instance 'js-body
647 :stmts (mapcar #'js-compile-to-statement body)))
648
649 (defmethod initialize-instance :after ((body js-body) &rest initargs)
650 (declare (ignore initargs))
651 (let* ((stmts (b-stmts body))
652 (last (last stmts))
653 (last-stmt (car last)))
654 (when (typep last-stmt 'js-body)
655 (setf (b-stmts body)
656 (nconc (butlast stmts)
657 (b-stmts last-stmt))))))
658
659
660 (defmethod js-to-statement-strings ((body js-body) start-pos)
661 (dwim-join (mapcar #'(lambda (x) (js-to-statement-strings x (+ start-pos 2)))
662 (b-stmts body))
663 (- 80 start-pos 2)
664 :join-after ";"
665 :append-to-last #'special-append-to-last
666 :start (b-indent body) :collect nil
667 :end ";"))
668
669 (defmethod js-to-strings ((body js-body) start-pos)
670 (dwim-join (mapcar #'(lambda (x) (js-to-strings x (+ start-pos 2)))
671 (b-stmts body))
672 (- 80 start-pos 2)
673 :append-to-last #'special-append-to-last
674 :join-after ","
675 :start (b-indent body)))
676
677 (defjsclass js-sub-body (js-body)
678 (stmts indent))
679
680 (defmethod js-to-statement-strings ((body js-sub-body) start-pos)
681 (declare (ignore start-pos))
682 (nconc (list "{") (call-next-method) (list "}")))
683
684 (defmethod expression-precedence ((body js-body))
685 (if (= (length (b-stmts body)) 1)
686 (expression-precedence (first (b-stmts body)))
687 (gethash 'comma *op-precedence-hash*)))
688
689 ;;; function definition
690
691 (defjsclass js-lambda (expression)
692 ((args :initarg :args :accessor lambda-args)
693 (body :initarg :body :accessor lambda-body)))
694
695 (define-js-compiler-macro lambda (args &rest body)
696 (make-instance 'js-lambda
697 :args (mapcar #'js-compile-to-symbol args)
698 :body (make-instance 'js-body
699 :indent " "
700 :stmts (mapcar #'js-compile-to-statement body))))
701
702 (defmethod js-to-strings ((lambda js-lambda) start-pos)
703 (let ((fun-header (dwim-join (mapcar #'(lambda (x)
704 (list (symbol-to-js x)))
705 (lambda-args lambda))
706 (- 80 start-pos 2)
707 :start (function-start-string lambda)
708 :end ") {" :join-after ","))
709 (fun-body (js-to-statement-strings (lambda-body lambda) (+ start-pos 2))))
710 (nconc fun-header fun-body (list "}"))))
711
712 (defmethod function-start-string ((lambda js-lambda))
713 "function (")
714
715 (defmethod js-to-statement-strings ((lambda js-lambda) start-pos)
716 (js-to-strings lambda start-pos))
717
718 (defjsclass js-defun (js-lambda)
719 ((name :initarg :name :accessor defun-name)))
720
721 (define-js-compiler-macro defun (name args &rest body)
722 (make-instance 'js-defun
723 :name (js-compile-to-symbol name)
724 :args (mapcar #'js-compile-to-symbol args)
725 :body (make-instance 'js-body
726 :indent " "
727 :stmts (mapcar #'js-compile-to-statement body))))
728
729 (defmethod function-start-string ((defun js-defun))
730 (format nil "function ~A(" (symbol-to-js (defun-name defun))))
731
732 ;;; object creation
733
734 (defjsclass js-object (expression)
735 ((slots :initarg :slots
736 :accessor o-slots)))
737
738 (define-js-compiler-macro create (&rest args)
739 (make-instance 'js-object
740 :slots (loop for (name val) on args by #'cddr
741 collect (list (js-compile-to-symbol name)
742 (js-compile-to-expression val)))))
743
744 (defmethod js-to-strings ((object js-object) start-pos)
745 (let ((value-string-lists
746 (mapcar #'(lambda (slot)
747 (dwim-join (list (js-to-strings (second slot) (+ start-pos 4)))
748 (- 80 start-pos 2)
749 :start (concatenate 'string (symbol-to-js (first slot)) " : ")
750 :white-space " ")) (o-slots object)))
751 (max-length (- 80 start-pos 2)))
752 (dwim-join value-string-lists max-length
753 :start "{ "
754 :end " }"
755 :join-after ", "
756 :white-space " "
757 :collect nil)))
758
759 (defjsclass js-slot-value (expression)
760 ((object :initarg :object
761 :accessor sv-object)
762 (slot :initarg :slot
763 :accessor sv-slot)))
764
765 (define-js-compiler-macro slot-value (obj slot)
766 (make-instance 'js-slot-value :object (js-compile-to-expression obj)
767 :slot (js-compile slot)))
768
769 (defmethod js-to-strings ((sv js-slot-value) start-pos)
770 (append-to-last (js-to-strings (sv-object sv) start-pos)
771 (if (symbolp (sv-slot sv))
772 (format nil ".~A" (symbol-to-js (sv-slot sv)))
773 (format nil "[~A]" (first (js-to-strings (sv-slot sv) 0))))))
774
775 (defjsmacro with-slots (slots object &rest body)
776 `(symbol-macrolet ,(mapcar #'(lambda (slot)
777 `(,slot '(slot-value ,object ',slot)))
778 slots)
779 ,@body))
780
781 ;;; macros
782
783 (define-js-compiler-macro macrolet (macros &rest body)
784 (let* ((macro-env (make-hash-table :test 'equal))
785 (*js-macro-env* (cons macro-env *js-macro-env*)))
786 (dolist (macro macros)
787 (destructuring-bind (name arglist &rest body) macro
788 (setf (gethash (symbol-name name) macro-env)
789 (compile nil `(lambda ,arglist ,@body)))))
790 (js-compile `(progn ,@body))))
791
792 (defjsmacro symbol-macrolet (macros &rest body)
793 `(macrolet ,(mapcar #'(lambda (macro)
794 `(,(first macro) () ,@(rest macro))) macros)
795 ,@body))
796
797 ;;; lisp eval
798
799 (defjsmacro lisp (&rest forms)
800 (eval (cons 'progn forms)))
801
802 ;;; if
803
804 (defjsclass js-if (expression)
805 ((test :initarg :test
806 :accessor if-test)
807 (then :initarg :then
808 :accessor if-then)
809 (else :initarg :else
810 :accessor if-else)))
811
812 (define-js-compiler-macro if (test then &optional else)
813 (make-instance 'js-if :test (js-compile-to-expression test)
814 :then (js-compile-to-body then :indent " ")
815 :else (when else
816 (js-compile-to-body else :indent " "))))
817
818 (defmethod initialize-instance :after ((if js-if) &rest initargs)
819 (declare (ignore initargs))
820 (when (and (if-then if)
821 (typep (if-then if) 'js-sub-body))
822 (change-class (if-then if) 'js-body))
823 (when (and (if-else if)
824 (typep (if-else if) 'js-sub-body))
825 (change-class (if-else if) 'js-body)))
826
827 (defmethod js-to-statement-strings ((if js-if) start-pos)
828 (let ((if-strings (dwim-join (list (js-to-strings (if-test if) 0))
829 (- 80 start-pos 2)
830 :start "if ("
831 :end ") {"))
832 (then-strings (js-to-statement-strings (if-then if) (+ start-pos 2)))
833 (else-strings (when (if-else if)
834 (js-to-statement-strings (if-else if)
835 (+ start-pos 2)))))
836 (nconc if-strings then-strings (if else-strings
837 (nconc (list "} else {") else-strings (list "}"))
838 (list "}")))))
839
840 (defmethod expression-precedence ((if js-if))
841 (gethash 'if *op-precedence-hash*))
842
843 (defmethod js-to-strings ((if js-if) start-pos)
844 (assert (typep (if-then if) 'expression))
845 (when (if-else if)
846 (assert (typep (if-else if) 'expression)))
847 (dwim-join (list (append-to-last (js-to-strings (if-test if) start-pos) " ?")
848 (let* ((new-then (make-instance 'js-body
849 :stmts (b-stmts (if-then if))
850 :indent ""))
851 (res (js-to-strings new-then start-pos)))
852 (if (>= (expression-precedence (if-then if))
853 (expression-precedence if))
854 (klammer res)
855 res))
856 (list ":")
857 (if (if-else if)
858 (let* ((new-else (make-instance 'js-body
859 :stmts (b-stmts (if-else if))
860 :indent ""))
861 (res (js-to-strings new-else start-pos)))
862 (if (>= (expression-precedence (if-else if))
863 (expression-precedence if))
864 (klammer res)
865 res))
866 (list "undefined")))
867 (- 80 start-pos 2)
868 :white-space " "))
869
870 (defjsmacro when (test &rest body)
871 `(if ,test (progn ,@body)))
872
873 (defjsmacro unless (test &rest body)
874 `(if (not ,test) (progn ,@body)))
875
876 ;;; single keyword expressions and statements
877
878 (defmacro define-js-single-op (name &optional (superclass 'expression))
879 (let ((js-name (intern (concatenate 'string "JS-" (symbol-name name)) #.*package*)))
880 `(progn
881 (defjsclass ,js-name (,superclass)
882 (value))
883 (define-js-compiler-macro ,name (value)
884 (make-instance ',js-name :value (js-compile-to-expression value)))
885 (defmethod ,(if (eql superclass 'expression)
886 'js-to-strings
887 'js-to-statement-strings) ((,name ,js-name) start-pos)
888 (dwim-join (list (js-to-strings (value ,name) (+ start-pos 2)))
889 (- 80 start-pos 2)
890 :start ,(concatenate 'string (string-downcase (symbol-name name)) " ")
891 :white-space " ")))))
892
893
894 (define-js-single-op return statement)
895 (define-js-single-op throw statement)
896 (define-js-single-op delete)
897 (define-js-single-op void)
898 (define-js-single-op typeof)
899 (define-js-single-op instanceof)
900 (define-js-single-op new)
901
902 ;;; assignment
903
904 (defjsclass js-setf (expression)
905 ((lhs :initarg :lhs :accessor setf-lhs)
906 (rhsides :initarg :rhsides :accessor setf-rhsides)))
907
908 (defun assignment-op (op)
909 (case op
910 (+ '+=)
911 (~ '~=)
912 (\& '\&=)
913 (\| '\|=)
914 (- '-=)
915 (* '*=)
916 (% '%=)
917 (>> '>>=)
918 (^ '^=)
919 (<< '<<=)
920 (>>> '>>>=)
921 (/ '/=)
922 (t nil)))
923
924 (defun make-js-test (lhs rhs)
925 (if (and (typep rhs 'op-form)
926 (member lhs (op-args rhs) :test #'js-equal))
927 (let ((args-without (remove lhs (op-args rhs)
928 :count 1 :test #'js-equal))
929 (args-without-first (remove lhs (op-args rhs)
930 :count 1 :end 1
931 :test #'js-equal))
932 (one (list (make-instance 'number-literal :value 1))))
933 #+nil
934 (format t "OPERATOR: ~S, ARGS-WITHOUT: ~S, ARGS-WITHOUT-FIRST ~S~%"
935 (operator rhs)
936 args-without
937 args-without-first)
938 (cond ((and (js-equal args-without one)
939 (eql (operator rhs) '+))
940 (make-instance 'one-op :pre-p nil :op "++"
941 :value lhs))
942 ((and (js-equal args-without-first one)
943 (eql (operator rhs) '-))
944 (make-instance 'one-op :pre-p nil :op "--"
945 :value lhs))
946 ((and (assignment-op (operator rhs))
947 (member (operator rhs)
948 '(+ *)))
949 (make-instance 'op-form
950 :operator (assignment-op (operator rhs))
951 :args (list lhs (make-instance 'op-form
952 :operator (operator rhs)
953 :args args-without))))
954 ((and (assignment-op (operator rhs))
955 (js-equal (first (op-args rhs)) lhs))
956 (make-instance 'op-form
957 :operator (assignment-op (operator rhs))
958 :args (list lhs (make-instance 'op-form
959 :operator (operator rhs)
960 :args (cdr (op-args rhs))))))
961 (t (make-instance 'js-setf :lhs lhs :rhsides (list rhs)))))
962 (make-instance 'js-setf :lhs lhs :rhsides (list rhs))))
963
964 (define-js-compiler-macro setf (&rest args)
965 (let ((assignments (loop for (lhs rhs) on args by #'cddr
966 for rexpr = (js-compile-to-expression rhs)
967 for lexpr = (js-compile-to-expression lhs)
968 collect (make-js-test lexpr rexpr))))
969 (if (= (length assignments) 1)
970 (first assignments)
971 (make-instance 'js-body :indent "" :stmts assignments))))
972
973 (defmethod js-to-strings ((setf js-setf) start-pos)
974 (dwim-join (cons (js-to-strings (setf-lhs setf) start-pos)
975 (mapcar #'(lambda (x) (js-to-strings x start-pos)) (setf-rhsides setf)))
976 (- 80 start-pos 2)
977 :join-after " ="))
978
979 (defmethod expression-precedence ((setf js-setf))
980 (gethash '= *op-precedence-hash*))
981
982 ;;; defvar
983
984 (defjsclass js-defvar (statement)
985 ((names :initarg :names :accessor var-names)
986 (value :initarg :value :accessor var-value)))
987
988 (define-js-compiler-macro defvar (name &optional value)
989 (make-instance 'js-defvar :names (list (js-compile-to-symbol name))
990 :value (when value (js-compile-to-expression value))))
991
992 (defmethod js-to-statement-strings ((defvar js-defvar) start-pos)
993 (dwim-join (nconc (mapcar #'(lambda (x) (list (symbol-to-js x))) (var-names defvar))
994 (when (var-value defvar)
995 (list (js-to-strings (var-value defvar) start-pos))))
996 (- 80 start-pos 2)
997 :join-after " ="
998 :start "var " :end ";"))
999
1000 ;;; let
1001
1002 (define-js-compiler-macro let (decls &rest body)
1003 (let ((single-defvar (make-instance 'js-defvar
1004 :names (mapcar #'js-compile-to-symbol
1005 (remove-if-not #'atom decls))
1006 :value nil))
1007 (defvars (mapcar #'(lambda (decl)
1008 (let ((name (first decl))
1009 (value (second decl)))
1010 (make-instance 'js-defvar
1011 :names (list (js-compile-to-symbol name))
1012 :value (js-compile-to-expression value))))
1013 (remove-if #'atom decls))))
1014 (make-instance 'js-sub-body
1015 :indent " "
1016 :stmts (nconc (when (var-names single-defvar) (list single-defvar))
1017 defvars
1018 (mapcar #'js-compile-to-statement body)))))
1019
1020 ;;; iteration
1021
1022 (defjsclass js-for (statement)
1023 ((vars :initarg :vars :accessor for-vars)
1024 (steps :initarg :steps :accessor for-steps)
1025 (check :initarg :check :accessor for-check)
1026 (body :initarg :body :accessor for-body)))
1027
1028 (defun make-for-vars (decls)
1029 (loop for decl in decls
1030 for var = (if (atom decl) decl (first decl))
1031 for init = (if (atom decl) nil (second decl))
1032 collect (make-instance 'js-defvar :names (list (js-compile-to-symbol var))
1033 :value (js-compile-to-expression init))))
1034
1035 (defun make-for-steps (decls)
1036 (loop for decl in decls
1037 when (= (length decl) 3)
1038 collect (js-compile-to-expression (third decl))))
1039
1040 (define-js-compiler-macro do (decls termination &rest body)
1041 (let ((vars (make-for-vars decls))
1042 (steps (make-for-steps decls))
1043 (check (js-compile-to-expression (list 'not (first termination))))
1044 (body (js-compile-to-body (cons 'progn body) :indent " ")))
1045 (make-instance 'js-for
1046 :vars vars
1047 :steps steps
1048 :check check
1049 :body body)))
1050
1051 (defjsmacro dotimes (iter &rest body)
1052 (let ((var (first iter))
1053 (times (second iter)))
1054 `(do ((,var 0 (1+ ,var)))
1055 ((>= ,var ,times))
1056 ,@body)))
1057
1058 (defjsmacro dolist (i-array &rest body)
1059 (let ((var (first i-array))
1060 (array (second i-array))
1061 (arrvar (js-gensym "arr"))
1062 (idx (js-gensym "i")))
1063 `(let ((,arrvar ,array))
1064 (do ((,idx 0 (1+ ,idx)))
1065 ((>= ,idx (slot-value ,arrvar 'length)))
1066 (let ((,var (aref ,arrvar ,idx)))
1067 ,@body)))))
1068
1069 (defmethod js-to-statement-strings ((for js-for) start-pos)
1070 (let* ((init (dwim-join (mapcar #'(lambda (x)
1071 (dwim-join (list (list (symbol-to-js (first (var-names x))))
1072 (js-to-strings (var-value x)
1073 (+ start-pos 2)))
1074 (- 80 start-pos 2)
1075 :join-after " ="))
1076 (for-vars for))
1077 (- 80 start-pos 2)
1078 :start "var " :join-after ","))
1079 (check (js-to-strings (for-check for) (+ start-pos 2)))
1080 (steps (dwim-join (mapcar #'(lambda (x var)
1081 (dwim-join
1082 (list (list (symbol-to-js (first (var-names var))))
1083 (js-to-strings x (- start-pos 2)))
1084 (- 80 start-pos 2)
1085 :join-after " ="))
1086 (for-steps for)
1087 (for-vars for))
1088 (- 80 start-pos 2)
1089 :join-after ","))
1090 (header (dwim-join (list init check steps)
1091 (- 80 start-pos 2)
1092 :start "for (" :end ") {"
1093 :join-after ";"))
1094 (body (js-to-statement-strings (for-body for) (+ start-pos 2))))
1095 (nconc header body (list "}"))))
1096
1097 (defjsclass for-each (statement)
1098 ((name :initarg :name :accessor fe-name)
1099 (value :initarg :value :accessor fe-value)
1100 (body :initarg :body :accessor fe-body)))
1101
1102 (define-js-compiler-macro doeach (decl &rest body)
1103 (make-instance 'for-each :name (js-compile-to-symbol (first decl))
1104 :value (js-compile-to-expression (second decl))
1105 :body (js-compile-to-body (cons 'progn body) :indent " ")))
1106
1107 (defmethod js-to-statement-strings ((fe for-each) start-pos)
1108 (let ((header (dwim-join (list (list (symbol-to-js (fe-name fe)))
1109 (list "in")
1110 (js-to-strings (fe-value fe) (+ start-pos 2)))
1111 (- 80 start-pos 2)
1112 :start "for (var "
1113 :end ") {"))
1114 (body (js-to-statement-strings (fe-body fe) (+ start-pos 2))))
1115 (nconc header body (list "}"))))
1116
1117 (defjsclass js-while (statement)
1118 ((check :initarg :check :accessor while-check)
1119 (body :initarg :body :accessor while-body)))
1120
1121 (define-js-compiler-macro while (check &rest body)
1122 (make-instance 'js-while
1123 :check (js-compile-to-expression check)
1124 :body (js-compile-to-body (cons 'progn body) :indent " ")))
1125
1126 (defmethod js-to-statement-strings ((while js-while) start-pos)
1127 (let ((header (dwim-join (list (js-to-strings (while-check while) (+ start-pos 2)))
1128 (- 80 start-pos 2)
1129 :start "while ("
1130 :end ") {"))
1131 (body (js-to-statement-strings (while-body while) (+ start-pos 2))))
1132 (nconc header body (list "}"))))
1133
1134 ;;; with
1135
1136 (defjsclass js-with (statement)
1137 ((obj :initarg :obj :accessor with-obj)
1138 (body :initarg :body :accessor with-body)))
1139
1140 (define-js-compiler-macro with (statement &rest body)
1141 (make-instance 'js-with
1142 :obj (js-compile-to-expression (first statement))
1143 :body (js-compile-to-body (cons 'progn body) :indent " ")))
1144
1145 (defmethod js-to-statement-strings ((with js-with) start-pos)
1146 (nconc (dwim-join (list (js-to-strings (with-obj with) (+ start-pos 2)))
1147 (- 80 start-pos 2)
1148 :start "with (" :end ") {")
1149 (js-to-statement-strings (with-body with) (+ start-pos 2))
1150 (list "}")))
1151
1152 ;;; case
1153
1154 (defjsclass js-switch (statement)
1155 ((value :initarg :value :accessor case-value)
1156 (clauses :initarg :clauses :accessor case-clauses)))
1157
1158 (define-js-compiler-macro switch (value &rest clauses)
1159 (let ((clauses (mapcar #'(lambda (clause)
1160 (let ((val (first clause))
1161 (body (cdr clause)))
1162 (list (if (eql val 'default)
1163 'default
1164 (js-compile-to-expression val))
1165 (js-compile-to-body (cons 'progn body) :indent " "))))
1166 clauses))
1167 (check (js-compile-to-expression value)))
1168 (make-instance 'js-switch :value check
1169 :clauses clauses)))
1170
1171 (defmethod js-to-statement-strings ((case js-switch) start-pos)
1172 (let ((body (mapcan #'(lambda (clause)
1173 (let ((val (car clause))
1174 (body (second clause)))
1175 (dwim-join (list (if (eql val 'default)
1176 (list "")
1177 (js-to-strings val (+ start-pos 2)))
1178 (js-to-statement-strings body (+ start-pos 2)))
1179 (- 80 start-pos 2)
1180 :start (if (eql val 'default) " default" " case ")
1181 :white-space " "
1182 :join-after ":"))) (case-clauses case))))
1183
1184 #+nil
1185 (format t "body: ~S~%" body)
1186 (nconc (dwim-join (list (js-to-strings (case-value case) (+ start-pos 2)))
1187 (- 80 start-pos 2)
1188 :start "switch (" :end ") {")
1189 body
1190 (list "}"))))
1191
1192 (defjsmacro case (value &rest clauses)
1193 (labels ((make-clause (val body more)
1194 (cond ((listp val)
1195 (append (mapcar #'list (butlast val))
1196 (make-clause (first (last val)) body more)))
1197 ((member val '(t otherwise))
1198 (make-clause 'default body more))
1199 (more `((,val ,@body break)))
1200 (t `((,val ,@body))))))
1201 `(switch ,value ,@(mapcon #'(lambda (x)
1202 (make-clause (car (first x))
1203 (cdr (first x))
1204 (rest x)))
1205 clauses))))
1206
1207 ;;; throw catch
1208
1209 (defjsclass js-try (statement)
1210 ((body :initarg :body :accessor try-body)
1211 (catch :initarg :catch :accessor try-catch)
1212 (finally :initarg :finally :accessor try-finally)))
1213
1214 (define-js-compiler-macro try (body &rest clauses)
1215 (let ((body (js-compile-to-body body :indent " "))
1216 (catch (cdr (assoc :catch clauses)))
1217 (finally (cdr (assoc :finally clauses))))
1218 (make-instance 'js-try
1219 :body body
1220 :catch (when catch (list (js-compile-to-symbol (caar catch))
1221 (js-compile-to-body (cons 'progn (cdr catch))
1222 :indent " ")))
1223 :finally (when finally (js-compile-to-body (cons 'progn finally)
1224 :indent " ")))))
1225
1226 (defmethod js-to-statement-strings ((try js-try) start-pos)
1227 (let* ((catch (try-catch try))
1228 (finally (try-finally try))
1229 (catch-list (when catch
1230 (nconc
1231 (dwim-join (list (list (symbol-to-js (first catch))))
1232 (- 80 start-pos 2)
1233 :start "} catch ("
1234 :end ") {")
1235 (js-to-statement-strings (second catch) (+ start-pos 2)))))
1236 (finally-list (when finally
1237 (nconc (list "} finally {")
1238 (js-to-statement-strings finally (+ start-pos 2))))))
1239 (nconc (list "try {")
1240 (js-to-statement-strings (try-body try) (+ start-pos 2))
1241 catch-list
1242 finally-list
1243 (list "}"))))
1244
1245 ;;; regex
1246
1247 (defjsclass regex (expression)
1248 (value))
1249
1250 (define-js-compiler-macro regex (regex)
1251 (make-instance 'regex :value (string regex)))
1252
1253 (defmethod js-to-strings ((regex regex) start-pos)
1254 (declare (ignore start-pos))
1255 (list (format nil "/~A/" (value regex))))
1256
1257 ;;; conditional compilation
1258
1259 (defjsclass cc-if ()
1260 ((test :initarg :test :accessor cc-if-test)
1261 (body :initarg :body :accessor cc-if-body)))
1262
1263 (defmethod js-to-statement-strings ((cc cc-if) start-pos)
1264 (nconc (list (format nil "/*@if ~A" (cc-if-test cc)))
1265 (mapcan #'(lambda (x) (js-to-strings x start-pos)) (cc-if-body cc))
1266 (list "@end @*/")))
1267
1268 (define-js-compiler-macro cc-if (test &rest body)
1269 (make-instance 'cc-if :test test
1270 :body (mapcar #'js-compile body)))
1271
1272 ;;; compiler
1273
1274 (defun js-compile (form)
1275 (setf form (js-expand-form form))
1276 (cond ((stringp form)
1277 (make-instance 'string-literal :value form))
1278 ((characterp form)
1279 (make-instance 'string-literal :value (string form)))
1280 ((numberp form)
1281 (make-instance 'number-literal :value form))
1282 ((symbolp form)
1283 (let ((c-macro (js-get-compiler-macro form)))
1284 (if c-macro
1285 (funcall c-macro)
1286 (make-instance 'js-variable :value form))))
1287 ((and (consp form)
1288 (eql (first form) 'quote))
1289 (second form))
1290 ((consp form)
1291 (js-compile-list form))
1292 (t (error "Unknown atomar expression ~S" form))))
1293
1294 (defun js-compile-list (form)
1295 (let* ((name (car form))
1296 (args (cdr form))
1297 (js-form (js-get-compiler-macro name)))
1298 (cond (js-form
1299 (apply js-form args))
1300
1301 ((op-form-p form)
1302 (make-instance 'op-form
1303 :operator (js-convert-op-name (js-compile-to-symbol (first form)))
1304 :args (mapcar #'js-compile-to-expression (rest form))))
1305
1306 ((method-call-p form)
1307 (make-instance 'method-call
1308 :method (js-compile-to-symbol (first form))
1309 :object (js-compile-to-expression (second form))
1310 :args (mapcar #'js-compile-to-expression (cddr form))))
1311
1312 ((funcall-form-p form)
1313 (make-instance 'function-call
1314 :function (js-compile-to-expression (first form))
1315 :args (mapcar #'js-compile-to-expression (rest form))))
1316
1317 (t (error "Unknown form ~S" form)))))
1318
1319 (defun js-compile-to-expression (form)
1320 (let ((res (js-compile form)))
1321 (assert (typep res 'expression))
1322 res))
1323
1324 (defun js-compile-to-symbol (form)
1325 (let ((res (js-compile form)))
1326 (when (typep res 'js-variable )
1327 (setf res (value res)))
1328 (assert (symbolp res))
1329 res))
1330
1331 (defun js-compile-to-statement (form)
1332 (let ((res (js-compile form)))
1333 (assert (typep res 'statement))
1334 res))
1335
1336 (defun js-compile-to-body (form &key (indent ""))
1337 (let ((res (js-compile-to-statement form)))
1338 (if (typep res 'js-body)
1339 (progn (setf (b-indent res) indent)
1340 res)
1341 (make-instance 'js-body
1342 :indent indent
1343 :stmts (list res)))))
1344
1345 ;;; Math library
1346
1347 (defjsmacro floor (expr)
1348 `(*Math.floor ,expr))
1349
1350 (defjsmacro random ()
1351 `(*Math.random))
1352
1353 ;;; helper functions
1354
1355 (defvar *gen-js-name-counter* 0)
1356
1357 (defun gen-js-name-string (&key (prefix "parenscript_"))
1358 "Generates a unique valid javascript identifier ()"
1359 (concatenate 'string
1360 prefix (princ-to-string (incf *gen-js-name-counter*))))
1361
1362 (defun gen-js-name (&key (prefix "parenscript_"))
1363 "Generate a new javascript identifier."
1364 (intern (gen-js-name-string :prefix prefix)
1365 (find-package :js)))
1366
1367 (defmacro with-unique-js-names (symbols &body body)
1368 "Evaluate BODY with the variables on SYMBOLS bound to new javascript identifiers.
1369
1370 Each element of SYMBOLS is either a symbol or a list of (symbol
1371 prefix)."
1372 `(let* ,(mapcar (lambda (symbol)
1373 (destructuring-bind (symbol &optional prefix)
1374 (if (consp symbol)
1375 symbol
1376 (list symbol))
1377 (if prefix
1378 `(,symbol (gen-js-name :prefix ,prefix))
1379 `(,symbol (gen-js-name)))))
1380 symbols)
1381 ,@body))
1382
1383 ;;; helper macros
1384
1385 (defjsmacro rebind (variables expression)
1386 "Creates a new js lexical environment and copies the given variable(s) there.
1387 Executes the body in the new environment. This has the same effect as a new
1388 (let () ...) form in lisp but works on the js side for js closures."
1389 (unless (listp variables)
1390 (setf variables (list variables)))
1391 `((lambda ()
1392 (let ((new-context (new *object)))
1393 ,@(loop for variable in variables
1394 do (setf variable (symbol-to-js variable))
1395 collect `(setf (slot-value new-context ,variable) (slot-value this ,variable)))
1396 (with (new-context)
1397 (return ,expression))))))
1398
1399 (define-js-compiler-macro js (&rest body)
1400 (make-instance 'string-literal
1401 :value (string-join (js-to-statement-strings
1402 (js-compile (cons 'progn body)) 0) " ")))
1403
1404 (define-js-compiler-macro js-inline (&rest body)
1405 (make-instance 'string-literal
1406 :value (concatenate
1407 'string
1408 "javascript:"
1409 (string-join (js-to-statement-strings
1410 (js-compile (cons 'progn body)) 0) " "))))
1411
1412
1413 (defmacro js (&rest body)
1414 `(js* '(progn ,@body)))
1415
1416 (defmacro js* (&rest body)
1417 "Return the javascript string representing BODY.
1418
1419 Body is evaluated."
1420 `(string-join
1421 (js-to-statement-strings (js-compile (list 'progn ,@body)) 0)
1422 (string #\Newline)))
1423
1424 (defun js-to-string (expr)
1425 (string-join
1426 (js-to-statement-strings (js-compile expr) 0)
1427 (string #\Newline)))
1428
1429 (defun js-to-line (expr)
1430 (string-join
1431 (js-to-statement-strings (js-compile expr) 0) " "))
1432
1433 (defmacro js-file (&rest body)
1434 `(html
1435 (:princ
1436 (js ,@body))))
1437
1438 (defmacro js-script (&rest body)
1439 `((:script :type "text/javascript")
1440 (:princ (format nil "~%// <![CDATA[~%"))
1441 (:princ (js ,@body))
1442 (:princ (format nil "~%// ]]>~%"))))
1443
1444 (defmacro js-inline (&rest body)
1445 `(js-inline* '(progn ,@body)))
1446
1447 (defmacro js-inline* (&rest body)
1448 "Just like JS-INLINE except that BODY is evaluated before being
1449 converted to javascript."
1450 `(concatenate 'string "javascript:"
1451 (string-join (js-to-statement-strings (js-compile (list 'progn ,@body)) 0) " ")))
1452