Commit | Line | Data |
---|---|---|
8e198a08 MB |
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") | |
8e198a08 MB |
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 | ||
bcf5db4d MB |
32 | (defun untouchable-string-p (string) |
33 | (and (> (length string) 1) | |
34 | (char= #\: (char string 0)))) | |
35 | ||
8e198a08 MB |
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 | |
bcf5db4d | 43 | (do-not-touch nil) |
8e198a08 MB |
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 | |
bcf5db4d MB |
51 | symbol (subseq symbol 1))) |
52 | ((untouchable-string-p symbol) | |
53 | (setf do-not-touch t | |
54 | symbol (subseq symbol 1)))) | |
8e198a08 | 55 | (flet ((reschar (c) |
bcf5db4d MB |
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) | |
8e198a08 MB |
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 | ||
8e198a08 MB |
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 | |
711dd89e HH |
121 | &key (start "") |
122 | end | |
123 | (join-before "") | |
124 | join-after | |
125 | (white-space (make-string (length start) :initial-element #\Space)) | |
126 | (separator " ") | |
8e198a08 MB |
127 | (append-to-last #'append-to-last) |
128 | (collect t)) | |
129 | #+nil | |
130 | (format t "value-string-lists: ~S~%" value-string-lists) | |
131 | ||
8e198a08 | 132 | ;;; collect single value-string-lists until line full |
551080b7 | 133 | |
8e198a08 MB |
134 | (do* ((string-lists value-string-lists (cdr string-lists)) |
135 | (string-list (car string-lists) (car string-lists)) | |
136 | (cur-elt start) | |
711dd89e | 137 | (is-first t nil) |
8e198a08 | 138 | (cur-empty t) |
8e198a08 MB |
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)))) | |
8e198a08 MB |
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))) | |
551080b7 | 156 | |
8e198a08 MB |
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 | |
711dd89e HH |
171 | (if (or is-first (and cur-empty (string= join-before ""))) |
172 | "" (concatenate 'string separator join-before)) | |
8e198a08 MB |
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 | |
711dd89e HH |
188 | cur-elt |
189 | (if (null res) | |
190 | "" join-before) | |
8e198a08 MB |
191 | (first string-list)) |
192 | (mapcar #'(lambda (x) (concatenate 'string white-space x)) | |
711dd89e HH |
193 | (cdr string-list)))) |
194 | res)) | |
8e198a08 MB |
195 | (setf cur-elt white-space cur-empty t))))) |
196 | ||
197 | (defmethod js-to-strings ((expression expression) start-pos) | |
30b3e3eb | 198 | (declare (ignore start-pos)) |
8e198a08 MB |
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) | |
30b3e3eb | 205 | (declare (ignore start-pos)) |
8e198a08 MB |
206 | (list (princ-to-string (value statement)))) |
207 | ||
208 | ;;; compiler macros | |
209 | ||
210 | (eval-when (:compile-toplevel :load-toplevel :execute) | |
3549e19d MB |
211 | (defvar *js-compiler-macros* (make-hash-table :test 'equal) |
212 | "*JS-COMPILER-MACROS* is a hash-table containing the functions corresponding | |
8e198a08 | 213 | to javascript special forms, indexed by their name. Javascript special |
b5b0fae3 AL |
214 | forms are compiler macros for JS expressions.") |
215 | ||
216 | (defun undefine-js-compiler-macro (name) | |
217 | (declare (type symbol name)) | |
218 | (when (gethash (symbol-name name) *js-compiler-macros*) | |
219 | (warn "Redefining compiler macro ~S" name) | |
220 | (remhash (symbol-name name) *js-compiler-macros*)))) | |
8e198a08 MB |
221 | |
222 | (defmacro define-js-compiler-macro (name lambda-list &rest body) | |
223 | "Define a javascript compiler macro NAME. Arguments are destructured | |
224 | according to LAMBDA-LIST. The resulting JS language types are appended | |
225 | to the ongoing javascript compilation." | |
226 | (let ((js-name (intern (concatenate 'string "JS-" (symbol-name name)) #.*package*))) | |
227 | `(eval-when (:compile-toplevel :load-toplevel :execute) | |
228 | (defun ,js-name ,lambda-list ,@body) | |
3549e19d | 229 | (setf (gethash ,(symbol-name name) *js-compiler-macros*) #',js-name)))) |
8e198a08 MB |
230 | |
231 | (defun js-compiler-macro-form-p (form) | |
992d307b MB |
232 | (when (and (symbolp (car form)) |
233 | (gethash (symbol-name (car form)) *js-compiler-macros*)) | |
8e198a08 MB |
234 | t)) |
235 | ||
236 | (defun js-get-compiler-macro (name) | |
992d307b MB |
237 | (when (symbolp name) |
238 | (gethash (symbol-name name) *js-compiler-macros*))) | |
8e198a08 MB |
239 | |
240 | ;;; macro expansion | |
241 | ||
242 | (eval-when (:compile-toplevel :load-toplevel :execute) | |
3549e19d | 243 | (defvar *js-macro-toplevel* (make-hash-table :test 'equal) |
8e198a08 MB |
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." | |
3549e19d MB |
252 | (unless (symbolp name) |
253 | (return-from lookup-macro nil)) | |
8e198a08 MB |
254 | (do ((env *js-macro-env* (cdr env))) |
255 | ((null env) nil) | |
3549e19d | 256 | (let ((val (gethash (symbol-name name) (car env)))) |
8e198a08 MB |
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." | |
8e198a08 | 264 | (let ((lambda-list (gensym))) |
ca493d55 | 265 | (undefine-js-compiler-macro name) |
3549e19d | 266 | `(setf (gethash ,(symbol-name name) *js-macro-toplevel*) |
8e198a08 | 267 | #'(lambda (&rest ,lambda-list) |
ca493d55 AL |
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)))))) | |
551080b7 | 277 | |
8e198a08 MB |
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))) | |
551080b7 | 287 | |
8e198a08 | 288 | ((js-compiler-macro-form-p expr) expr) |
551080b7 | 289 | |
8e198a08 MB |
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 | ||
94a05cdf | 333 | (defmethod js-to-strings ((array array-literal) start-pos) |
8e198a08 MB |
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 | ||
c95a06f8 MB |
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 | ||
8e198a08 MB |
388 | ;;; string literals |
389 | ||
390 | (defjsclass string-literal (expression) | |
391 | (value)) | |
392 | ||
0ef142d6 MB |
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.") | |
ec8df470 | 399 | |
8e198a08 | 400 | (defmethod js-to-strings ((string string-literal) start-pos) |
72fcbf89 HH |
401 | (declare (ignore start-pos) |
402 | (inline lisp-special-char-to-js)) | |
8e8162b6 MB |
403 | (list (with-output-to-string (escaped) |
404 | (loop | |
ec8df470 | 405 | initially (write-char *js-quote-char* escaped) |
72fcbf89 HH |
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))) | |
ec8df470 | 417 | finally (write-char *js-quote-char* escaped))))) |
72fcbf89 HH |
418 | |
419 | (defparameter *js-lisp-escaped-chars* | |
420 | '((#\' . #\') | |
421 | (#\\ . #\\) | |
422 | (#\b . #\Backspace) | |
a89b3fb8 | 423 | (#\f . #.(code-char 12)) |
72fcbf89 HH |
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*))) | |
8e198a08 MB |
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) | |
30b3e3eb | 442 | (declare (ignore start-form)) |
8e198a08 MB |
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)))) | |
711dd89e HH |
518 | (dwim-join value-string-lists max-length :join-before op-string) |
519 | )) | |
8e198a08 MB |
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 ","))) | |
5ae77c6e MB |
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 ""))))) | |
8e198a08 MB |
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) | |
30b3e3eb | 681 | (declare (ignore start-pos)) |
8e198a08 MB |
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 | ||
d3694c57 MB |
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))) | |
8e198a08 MB |
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 | ||
d3694c57 MB |
729 | (defmethod function-start-string ((defun js-defun)) |
730 | (format nil "function ~A(" (symbol-to-js (defun-name defun)))) | |
8e198a08 MB |
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) | |
0c659e80 | 767 | :slot (js-compile slot))) |
8e198a08 MB |
768 | |
769 | (defmethod js-to-strings ((sv js-slot-value) start-pos) | |
770 | (append-to-last (js-to-strings (sv-object sv) start-pos) | |
0c659e80 HH |
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)))))) | |
8e198a08 MB |
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) | |
3549e19d | 784 | (let* ((macro-env (make-hash-table :test 'equal)) |
8e198a08 MB |
785 | (*js-macro-env* (cons macro-env *js-macro-env*))) |
786 | (dolist (macro macros) | |
787 | (destructuring-bind (name arglist &rest body) macro | |
3549e19d | 788 | (setf (gethash (symbol-name name) macro-env) |
8e198a08 MB |
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))))) | |
551080b7 | 1019 | |
8e198a08 MB |
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))) | |
807be2bc IT |
1054 | `(do ((,var 0 (1+ ,var))) |
1055 | ((>= ,var ,times)) | |
8e198a08 MB |
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)) | |
807be2bc | 1064 | (do ((,idx 0 (1+ ,idx))) |
8e198a08 MB |
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 | ||
3c393e09 | 1154 | (defjsclass js-switch (statement) |
8e198a08 MB |
1155 | ((value :initarg :value :accessor case-value) |
1156 | (clauses :initarg :clauses :accessor case-clauses))) | |
1157 | ||
3c393e09 | 1158 | (define-js-compiler-macro switch (value &rest clauses) |
8e198a08 MB |
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))) | |
3c393e09 | 1168 | (make-instance 'js-switch :value check |
8e198a08 MB |
1169 | :clauses clauses))) |
1170 | ||
3c393e09 | 1171 | (defmethod js-to-statement-strings ((case js-switch) start-pos) |
8e198a08 MB |
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 | ||
3c393e09 HH |
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 | ||
8e198a08 MB |
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 | ||
e6544c7a MB |
1253 | (defmethod js-to-strings ((regex regex) start-pos) |
1254 | (declare (ignore start-pos)) | |
1255 | (list (format nil "/~A/" (value regex)))) | |
1256 | ||
8e198a08 MB |
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)) | |
2e40c094 AL |
1278 | ((characterp form) |
1279 | (make-instance 'string-literal :value (string form))) | |
8e198a08 MB |
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 | |
37e52bad | 1346 | |
8e198a08 MB |
1347 | (defjsmacro floor (expr) |
1348 | `(*Math.floor ,expr)) | |
1349 | ||
1350 | (defjsmacro random () | |
1351 | `(*Math.random)) | |
1352 | ||
37e52bad MB |
1353 | ;;; helper functions |
1354 | ||
1355 | (defvar *gen-js-name-counter* 0) | |
1356 | ||
513e5ba0 MB |
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 | ||
37e52bad | 1362 | (defun gen-js-name (&key (prefix "parenscript_")) |
2175ad09 | 1363 | "Generate a new javascript identifier." |
513e5ba0 | 1364 | (intern (gen-js-name-string :prefix prefix) |
37e52bad MB |
1365 | (find-package :js))) |
1366 | ||
1367 | (defmacro with-unique-js-names (symbols &body body) | |
2175ad09 MB |
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)." | |
37e52bad MB |
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 | ||
8e198a08 MB |
1383 | ;;; helper macros |
1384 | ||
94bde1c4 AL |
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 | ||
8e198a08 MB |
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) " ")))) | |
551080b7 | 1411 | |
8e198a08 MB |
1412 | |
1413 | (defmacro js (&rest body) | |
f0b5d9e0 | 1414 | `(js* '(progn ,@body))) |
8e198a08 | 1415 | |
d006f536 | 1416 | (defmacro js* (&rest body) |
f0b5d9e0 MB |
1417 | "Return the javascript string representing BODY. |
1418 | ||
1419 | Body is evaluated." | |
d006f536 MB |
1420 | `(string-join |
1421 | (js-to-statement-strings (js-compile (list 'progn ,@body)) 0) | |
1422 | (string #\Newline))) | |
1423 | ||
8e198a08 MB |
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) | |
d66981b9 | 1445 | `(js-inline* '(progn ,@body))) |
8e198a08 | 1446 | |
d006f536 MB |
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 |