Commit | Line | Data |
---|---|---|
8e198a08 MB |
1 | (in-package :js) |
2 | ||
3 | ;;; javascript name conversion | |
4 | ||
5 | (defvar *special-chars* | |
6 | '((#\! . "Bang") | |
7 | (#\? . "What") | |
8 | (#\# . "Hash") | |
9 | (#\$ . "Dollar") | |
10 | (#\@ . "At") | |
11 | (#\% . "Percent") | |
12 | (#\+ . "Plus"))) | |
13 | ||
14 | (defun string-chars (string) | |
15 | (coerce string 'list)) | |
16 | ||
17 | (defun constant-string-p (string) | |
18 | (let ((len (length string)) | |
19 | (constant-chars '(#\+ #\*))) | |
20 | (and (> len 2) | |
21 | (member (char string 0) constant-chars) | |
22 | (member (char string (1- len)) constant-chars)))) | |
23 | ||
24 | (defun first-uppercase-p (string) | |
25 | (and (> (length string) 1) | |
26 | (member (char string 0) '(#\+ #\*)))) | |
27 | ||
28 | (defun symbol-to-js (symbol) | |
29 | (when (symbolp symbol) | |
30 | (setf symbol (symbol-name symbol))) | |
31 | (let (res | |
32 | (lowercase t) | |
33 | (all-uppercase nil)) | |
34 | (cond ((constant-string-p symbol) | |
35 | (setf all-uppercase t | |
36 | symbol (subseq symbol 1 (1- (length symbol))))) | |
37 | ((first-uppercase-p symbol) | |
38 | (setf lowercase nil | |
39 | symbol (subseq symbol 1)))) | |
40 | (flet ((reschar (c) | |
41 | (push (if (and lowercase (not all-uppercase)) | |
42 | (char-downcase c) | |
43 | (char-upcase c)) res) | |
44 | (setf lowercase t))) | |
45 | (dotimes (i (length symbol)) | |
46 | (let ((c (char symbol i))) | |
47 | (cond | |
48 | ((eql c #\-) | |
49 | (setf lowercase (not lowercase))) | |
50 | ((assoc c *special-chars*) | |
51 | (dolist (i (coerce (cdr (assoc c *special-chars*)) 'list)) | |
52 | (reschar i))) | |
53 | (t (reschar c)))))) | |
54 | (coerce (nreverse res) 'string))) | |
55 | ||
56 | ;;; Tokens | |
57 | ||
58 | ;;; break | |
59 | ;;; continue | |
60 | ;;; delete | |
61 | ;;; else | |
62 | ;;; if | |
63 | ;;; in | |
64 | ;;; new | |
65 | ;;; return | |
66 | ;;; this | |
67 | ;;; var | |
68 | ;;; instanceof | |
69 | ;;; typeof | |
70 | ;;; void | |
71 | ;;; function | |
72 | ;;; case | |
73 | ;;; default | |
74 | ;;; do | |
75 | ;;; for | |
76 | ;;; switch | |
77 | ;;; while | |
78 | ;;; with | |
79 | ;;; throw | |
80 | ;;; | |
81 | ;;; TODO: | |
82 | ;;; catch | |
83 | ;;; finally | |
84 | ;;; try | |
85 | ||
86 | ;;; Punctuators | |
87 | ||
88 | ;;; { } ( ) [ ] | |
89 | ;;; . ; , < > <= | |
90 | ;;; >= == != === !== | |
91 | ;;; + - * % ++ -- | |
92 | ;;; << >> >>> & | ^ | |
93 | ;;; ! ~ && || ? : | |
94 | ;;; = += -= *= %= <<= | |
95 | ;;; >>= >>>= &= |= ^= | |
96 | ;;; / /= | |
97 | ||
98 | ;;; Literals | |
99 | ||
100 | ;;; null true false | |
101 | ||
102 | ;;; js language types | |
103 | ||
104 | (defclass statement () | |
105 | ((value :initarg :value :accessor value))) | |
106 | ||
107 | (defclass expression (statement) | |
108 | ()) | |
109 | ||
110 | ;;; indenter | |
111 | ||
112 | (defun special-append-to-last (form elt) | |
113 | (flet ((special-append (form elt) | |
114 | (let ((len (length form))) | |
115 | (if (and (> len 0) | |
116 | (member (char form (1- len)) | |
117 | '(#\; #\, #\}))) | |
118 | form | |
119 | (concatenate 'string form elt))))) | |
120 | (cond ((stringp form) | |
121 | (special-append form elt)) | |
122 | ((consp form) | |
123 | (let ((last (last form))) | |
124 | (if (stringp (car last)) | |
125 | (rplaca last (special-append (car last) elt)) | |
126 | (append-to-last (car last) elt)) | |
127 | form)) | |
128 | (t (error "unsupported form ~S" form))))) | |
129 | ||
130 | (defun dwim-join (value-string-lists max-length | |
131 | &key start end | |
132 | join-before join-after | |
133 | white-space (separator " ") | |
134 | (append-to-last #'append-to-last) | |
135 | (collect t)) | |
136 | #+nil | |
137 | (format t "value-string-lists: ~S~%" value-string-lists) | |
138 | ||
139 | (unless start | |
140 | (setf start "")) | |
141 | ||
142 | (unless join-before | |
143 | (setf join-before "")) | |
144 | ||
145 | ;;; collect single value-string-lists until line full | |
551080b7 | 146 | |
8e198a08 MB |
147 | (do* ((string-lists value-string-lists (cdr string-lists)) |
148 | (string-list (car string-lists) (car string-lists)) | |
149 | (cur-elt start) | |
150 | (cur-empty t) | |
151 | (white-space (or white-space (make-string (length start) :initial-element #\Space))) | |
152 | (res nil)) | |
153 | ((null string-lists) | |
154 | (unless cur-empty | |
155 | (push cur-elt res)) | |
156 | (when end | |
157 | (setf (first res) | |
158 | (funcall append-to-last (first res) end))) | |
159 | (nreverse res)) | |
160 | ||
161 | #+nil | |
162 | (format t "string-list: ~S~%" string-list) | |
163 | ||
164 | (when join-after | |
165 | (unless (null (cdr string-lists)) | |
166 | (funcall append-to-last string-list join-after))) | |
551080b7 | 167 | |
8e198a08 MB |
168 | (if (and collect (= (length string-list) 1)) |
169 | (progn | |
170 | #+nil | |
171 | (format t "cur-elt: ~S line-length ~D, max-length ~D, string: ~S~%" | |
172 | cur-elt | |
173 | (+ (length (first string-list)) | |
174 | (length cur-elt)) | |
175 | max-length | |
176 | (first string-list)) | |
177 | (if (or cur-empty | |
178 | (< (+ (length (first string-list)) | |
179 | (length cur-elt)) max-length)) | |
180 | (setf cur-elt | |
181 | (concatenate 'string cur-elt | |
182 | (if cur-empty "" (concatenate 'string separator join-before)) | |
183 | (first string-list)) | |
184 | cur-empty nil) | |
185 | (progn | |
186 | (push cur-elt res) | |
187 | (setf cur-elt (concatenate 'string white-space | |
188 | join-before (first string-list)) | |
189 | cur-empty nil)))) | |
190 | ||
191 | (progn | |
192 | (unless cur-empty | |
193 | (push cur-elt res) | |
194 | (setf cur-elt white-space | |
195 | cur-empty t)) | |
196 | (setf res (nconc (nreverse | |
197 | (cons (concatenate 'string | |
198 | cur-elt (if (null res) | |
199 | "" join-before) | |
200 | (first string-list)) | |
201 | (mapcar #'(lambda (x) (concatenate 'string white-space x)) | |
202 | (cdr string-list)))) res)) | |
203 | (setf cur-elt white-space cur-empty t))))) | |
204 | ||
205 | (defmethod js-to-strings ((expression expression) start-pos) | |
206 | (list (princ-to-string (value expression)))) | |
207 | ||
208 | (defmethod js-to-statement-strings ((expression expression) start-pos) | |
209 | (js-to-strings expression start-pos)) | |
210 | ||
211 | (defmethod js-to-statement-strings ((statement statement) start-pos) | |
212 | (list (princ-to-string (value statement)))) | |
213 | ||
214 | ;;; compiler macros | |
215 | ||
216 | (eval-when (:compile-toplevel :load-toplevel :execute) | |
217 | (defvar *js-compiler-macros* (make-hash-table) | |
218 | "*JS-COMPILER-MACROS* is a hash-table containing the functions corresponding | |
219 | to javascript special forms, indexed by their name. Javascript special | |
220 | forms are compiler macros for JS expressions.")) | |
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))))) | |
227 | `(progn (defun ,js-name ,lambda-list ,@body) | |
228 | (setf (gethash ',name *js-compiler-macros*) #',js-name)))) | |
229 | ||
230 | (defun js-compiler-macro-form-p (form) | |
231 | (when (gethash (car form) *js-compiler-macros*) | |
232 | t)) | |
233 | ||
234 | (defun js-get-compiler-macro (name) | |
235 | (gethash name *js-compiler-macros*)) | |
236 | ||
237 | ;;; macro expansion | |
238 | ||
239 | (eval-when (:compile-toplevel :load-toplevel :execute) | |
240 | (defvar *js-macro-toplevel* (make-hash-table) | |
241 | "Toplevel of macro expansion, holds all the toplevel javascript macros.") | |
242 | (defvar *js-macro-env* (list *js-macro-toplevel*) | |
243 | "Current macro environment.")) | |
244 | ||
245 | (defun lookup-macro (name) | |
246 | "Lookup the macro NAME in the current macro expansion | |
247 | environment. Returns the macro and the parent macro environment of | |
248 | this macro." | |
249 | (do ((env *js-macro-env* (cdr env))) | |
250 | ((null env) nil) | |
251 | (let ((val (gethash name (car env)))) | |
252 | (when val | |
253 | (return-from lookup-macro | |
254 | (values val (or (cdr env) | |
255 | (list *js-macro-toplevel*)))))))) | |
256 | ||
257 | (defmacro defjsmacro (name args &rest body) | |
258 | "Define a javascript macro, and store it in the toplevel macro environment." | |
259 | (when (gethash name *js-compiler-macros*) | |
260 | (warn "Redefining compiler macro ~S" name) | |
261 | (remhash name *js-compiler-macros*)) | |
262 | (let ((lambda-list (gensym))) | |
263 | `(setf (gethash ',name *js-macro-toplevel*) | |
264 | #'(lambda (&rest ,lambda-list) | |
265 | (destructuring-bind ,args ,lambda-list ,@body))))) | |
551080b7 | 266 | |
8e198a08 MB |
267 | (defun js-expand-form (expr) |
268 | "Expand a javascript form." | |
269 | (cond ((atom expr) | |
270 | (multiple-value-bind (js-macro macro-env) | |
271 | (lookup-macro expr) | |
272 | (if js-macro | |
273 | (js-expand-form (let ((*js-macro-env* macro-env)) | |
274 | (funcall js-macro))) | |
275 | expr))) | |
551080b7 | 276 | |
8e198a08 | 277 | ((js-compiler-macro-form-p expr) expr) |
551080b7 | 278 | |
8e198a08 MB |
279 | ((equal (first expr) 'quote) expr) |
280 | ||
281 | (t (let ((js-macro (lookup-macro (car expr)))) | |
282 | (if js-macro | |
283 | (js-expand-form (apply js-macro (cdr expr))) | |
284 | expr))))) | |
285 | ||
286 | ;;; literals | |
287 | ||
288 | (defmacro defjsliteral (name string) | |
289 | "Define a Javascript literal that will expand to STRING." | |
290 | `(define-js-compiler-macro ,name () (make-instance 'expression :value ,string))) | |
291 | ||
292 | (defjsliteral this "this") | |
293 | (defjsliteral t "true") | |
294 | (defjsliteral nil "null") | |
295 | (defjsliteral false "false") | |
296 | (defjsliteral undefined "undefined") | |
297 | ||
298 | (defmacro defjskeyword (name string) | |
299 | "Define a Javascript keyword that will expand to STRING." | |
300 | `(define-js-compiler-macro ,name () (make-instance 'statement :value ,string))) | |
301 | ||
302 | (defjskeyword break "break") | |
303 | (defjskeyword continue "continue") | |
304 | ||
305 | ;;; array literals | |
306 | ||
307 | (defclass array-literal (expression) | |
308 | ((values :initarg :values :accessor array-values))) | |
309 | ||
310 | (define-js-compiler-macro array (&rest values) | |
311 | (make-instance 'array-literal | |
312 | :values (mapcar #'js-compile-to-expression values))) | |
313 | ||
314 | (defjsmacro list (&rest values) | |
315 | `(array ,@values)) | |
316 | ||
317 | (defmethod js-to-strings ((array array-literal) start-pos) | |
318 | (let ((value-string-lists | |
319 | (mapcar #'(lambda (x) (js-to-strings x (+ start-pos 2))) | |
320 | (array-values array))) | |
321 | (max-length (- 80 start-pos 2))) | |
322 | (dwim-join value-string-lists max-length | |
323 | :start "[ " :end " ]" | |
324 | :join-after ","))) | |
325 | ||
326 | (defclass js-aref (expression) | |
327 | ((array :initarg :array | |
328 | :accessor aref-array) | |
329 | (index :initarg :index | |
330 | :accessor aref-index))) | |
331 | ||
332 | (define-js-compiler-macro aref (array &rest coords) | |
333 | (make-instance 'js-aref | |
334 | :array (js-compile-to-expression array) | |
335 | :index (mapcar #'js-compile-to-expression coords))) | |
336 | ||
337 | (defmethod js-to-strings ((aref js-aref) start-pos) | |
338 | (dwim-join (cons (js-to-strings (aref-array aref) start-pos) | |
339 | (mapcar #'(lambda (x) (dwim-join (list (js-to-strings x (+ start-pos 2))) | |
340 | (- 80 start-pos 2) | |
341 | :start "[" :end "]")) | |
342 | (aref-index aref))) | |
343 | (- 80 start-pos 2) :separator "" | |
344 | :white-space " ")) | |
345 | ||
346 | ;;; string literals | |
347 | ||
348 | (defclass string-literal (expression) | |
349 | ()) | |
350 | ||
351 | (defmethod js-to-strings ((string string-literal) start-pos) | |
352 | (declare (ignore start-pos)) | |
353 | (list (prin1-to-string (value string)))) | |
354 | ||
355 | ;;; number literals | |
356 | ||
357 | (defclass number-literal (expression) | |
358 | ()) | |
359 | ||
360 | ;;; variables | |
361 | ||
362 | (defclass js-variable (expression) | |
363 | ()) | |
364 | ||
365 | (defmethod js-to-strings ((v js-variable) start-form) | |
366 | (list (symbol-to-js (value v)))) | |
367 | ||
368 | ;;; arithmetic operators | |
369 | ||
370 | (eval-when (:compile-toplevel :load-toplevel :execute) | |
371 | ||
372 | (defparameter *op-precedence-hash* (make-hash-table)) | |
373 | ||
374 | (defparameter *op-precedences* | |
375 | '((aref) | |
376 | (slot-value) | |
377 | (! not ~) | |
378 | (* / %) | |
379 | (+ -) | |
380 | (<< >>) | |
381 | (>>>) | |
382 | (< > <= >=) | |
383 | (in if) | |
384 | (eql == != = ) | |
385 | (=== !==) | |
386 | (&) | |
387 | (^) | |
388 | (\|) | |
389 | (\&\& and) | |
390 | (\|\| or) | |
391 | (setf) | |
392 | (comma))) | |
393 | ||
394 | ;;; generate the operator precedences from *OP-PRECEDENCES* | |
395 | (let ((precedence 1)) | |
396 | (dolist (ops *op-precedences*) | |
397 | (dolist (op ops) | |
398 | (setf (gethash op *op-precedence-hash*) precedence)) | |
399 | (incf precedence)))) | |
400 | ||
401 | (defun js-convert-op-name (op) | |
402 | (case op | |
403 | (and '\&\&) | |
404 | (or '\|\|) | |
405 | (not '!) | |
406 | (eql '\=\=) | |
407 | (= '\=\=) | |
408 | (t op))) | |
409 | ||
410 | (defclass op-form (expression) | |
411 | ((operator :initarg :operator :accessor operator) | |
412 | (args :initarg :args :accessor op-args))) | |
413 | ||
414 | (defun op-form-p (form) | |
415 | (and (listp form) | |
416 | (not (js-compiler-macro-form-p form)) | |
417 | (not (null (gethash (first form) *op-precedence-hash*))))) | |
418 | ||
419 | (defun klammer (string-list) | |
420 | (prepend-to-first string-list "(") | |
421 | (append-to-last string-list ")") | |
422 | string-list) | |
423 | ||
424 | (defmethod expression-precedence ((expression expression)) | |
425 | 0) | |
426 | ||
427 | (defmethod expression-precedence ((form op-form)) | |
428 | (gethash (operator form) *op-precedence-hash*)) | |
429 | ||
430 | (defmethod js-to-strings ((form op-form) start-pos) | |
431 | (let* ((precedence (expression-precedence form)) | |
432 | (value-string-lists | |
433 | (mapcar #'(lambda (x) | |
434 | (let ((string-list (js-to-strings x (+ start-pos 2)))) | |
435 | (if (>= (expression-precedence x) precedence) | |
436 | (klammer string-list) | |
437 | string-list))) | |
438 | (op-args form))) | |
439 | (max-length (- 80 start-pos 2)) | |
440 | (op-string (format nil "~A " (operator form)))) | |
441 | (dwim-join value-string-lists max-length :join-before op-string))) | |
442 | ||
443 | (defjsmacro 1- (form) | |
444 | `(- ,form 1)) | |
445 | ||
446 | (defjsmacro 1+ (form) | |
447 | `(+ ,form 1)) | |
448 | ||
449 | (defclass one-op (expression) | |
450 | ((pre-p :initarg :pre-p | |
451 | :initform nil | |
452 | :accessor one-op-pre-p) | |
453 | (op :initarg :op | |
454 | :accessor one-op))) | |
455 | ||
456 | (defmethod js-to-strings ((one-op one-op) start-pos) | |
457 | (let* ((value (value one-op)) | |
458 | (value-strings (js-to-strings value start-pos))) | |
459 | (when (typep value 'op-form) | |
460 | (setf value-strings (klammer value-strings))) | |
461 | (if (one-op-pre-p one-op) | |
462 | (prepend-to-first value-strings | |
463 | (one-op one-op)) | |
464 | (append-to-last value-strings | |
465 | (one-op one-op))))) | |
466 | ||
467 | (define-js-compiler-macro incf (x) | |
468 | (make-instance 'one-op :pre-p t :op "++" | |
469 | :value (js-compile-to-expression x))) | |
470 | (define-js-compiler-macro ++ (x) | |
471 | (make-instance 'one-op :pre-p nil :op "++" | |
472 | :value (js-compile-to-expression x))) | |
473 | (define-js-compiler-macro decf (x) | |
474 | (make-instance 'one-op :pre-p t :op "--" | |
475 | :value (js-compile-to-expression x))) | |
476 | (define-js-compiler-macro -- (x) | |
477 | (make-instance 'one-op :pre-p nil :op "--" | |
478 | :value (js-compile-to-expression x))) | |
479 | ||
480 | ||
481 | (define-js-compiler-macro not (x) | |
482 | (let ((value (js-compile-to-expression x))) | |
483 | (if (typep value 'op-form) | |
484 | (let ((new-op (case (operator value) | |
485 | (== '!=) | |
486 | (< '>=) | |
487 | (> '<=) | |
488 | (<= '>) | |
489 | (>= '<) | |
490 | (!= '==) | |
491 | (=== '!==) | |
492 | (!== '===) | |
493 | (t nil)))) | |
494 | (if new-op | |
495 | (make-instance 'op-form :operator new-op | |
496 | :args (op-args value)) | |
497 | (make-instance 'one-op :pre-p t :op "!" | |
498 | :value value))) | |
499 | (make-instance 'one-op :pre-p t :op "!" | |
500 | :value value)))) | |
501 | ||
502 | ;;; function calls | |
503 | ||
504 | (defclass function-call (expression) | |
505 | ((function :initarg :function :accessor f-function) | |
506 | (args :initarg :args :accessor f-args))) | |
507 | ||
508 | (defun funcall-form-p (form) | |
509 | (and (listp form) | |
510 | (not (op-form-p form)) | |
511 | (not (js-compiler-macro-form-p form)))) | |
512 | ||
513 | (defmethod js-to-strings ((form function-call) start-pos) | |
514 | (let ((value-string-lists | |
515 | (mapcar #'(lambda (x) (js-to-strings x (+ start-pos 2))) | |
516 | (f-args form))) | |
517 | (max-length (- 80 start-pos 2))) | |
518 | (dwim-join value-string-lists max-length | |
519 | :start (format nil "~A(" (symbol-to-js (f-function form))) | |
520 | :end ")" | |
521 | :join-after ","))) | |
522 | ||
523 | (defclass method-call (expression) | |
524 | ((method :initarg :method :accessor m-method) | |
525 | (args :initarg :args :accessor m-args))) | |
526 | ||
527 | (defun method-call-p (form) | |
528 | (and (funcall-form-p form) | |
529 | (eql (char (symbol-name (first form)) 0) #\.))) | |
530 | ||
531 | ;;; body forms | |
532 | ||
533 | (defclass js-body (expression) | |
534 | ((stmts :initarg :stmts :accessor b-stmts) | |
535 | (indent :initarg :indent :initform "" :accessor b-indent))) | |
536 | ||
537 | (define-js-compiler-macro progn (&rest body) | |
538 | (make-instance 'js-body | |
539 | :stmts (mapcar #'js-compile-to-statement body))) | |
540 | ||
541 | (defmethod js-to-statement-strings ((body js-body) start-pos) | |
542 | (dwim-join (mapcar #'(lambda (x) (js-to-statement-strings x (+ start-pos 2))) | |
543 | (b-stmts body)) | |
544 | (- 80 start-pos 2) | |
545 | :join-after ";" | |
546 | :append-to-last #'special-append-to-last | |
547 | :start (b-indent body) :collect nil | |
548 | :end ";")) | |
549 | ||
550 | (defmethod js-to-strings ((body js-body) start-pos) | |
551 | (dwim-join (mapcar #'(lambda (x) (js-to-strings x (+ start-pos 2))) | |
552 | (b-stmts body)) | |
553 | (- 80 start-pos 2) | |
554 | :append-to-last #'special-append-to-last | |
555 | :join-after "," | |
556 | :start (b-indent body))) | |
557 | ||
558 | (defclass js-sub-body (js-body) | |
559 | ()) | |
560 | ||
561 | (defmethod js-to-statement-strings ((body js-sub-body) start-pos) | |
562 | (nconc (list "{") (call-next-method) (list "}"))) | |
563 | #+nil | |
564 | (dwim-join (mapcar #'(lambda (x) (js-to-statement-strings x (+ start-pos 2))) | |
565 | (b-stmts body)) | |
566 | (- 80 start-pos 2) | |
567 | :start (format nil "{~% ") | |
568 | :end (format nil "~%}") | |
569 | :white-space " " :collect nil) | |
570 | ||
571 | (defmethod expression-precedence ((body js-body)) | |
572 | (if (= (length (b-stmts body)) 1) | |
573 | (expression-precedence (first (b-stmts body))) | |
574 | (gethash 'comma *op-precedence-hash*))) | |
575 | ||
576 | ;;; function definition | |
577 | ||
578 | (defclass js-defun (expression) | |
579 | ((name :initarg :name :accessor d-name) | |
580 | (args :initarg :args :accessor d-args) | |
581 | (body :initarg :body :accessor d-body))) | |
582 | ||
583 | (define-js-compiler-macro defun (name args &rest body) | |
584 | (make-instance 'js-defun | |
585 | :name (js-compile-to-symbol name) | |
586 | :args (mapcar #'js-compile-to-symbol args) | |
587 | :body (make-instance 'js-body | |
588 | :indent " " | |
589 | :stmts (mapcar #'js-compile-to-statement body)))) | |
590 | ||
591 | (defmethod js-to-strings ((defun js-defun) start-pos) | |
592 | (let ((fun-header (dwim-join (mapcar #'(lambda (x) (list (symbol-to-js x))) | |
593 | (d-args defun)) | |
594 | (- 80 start-pos 2) | |
595 | :start (format nil "function ~A(" | |
596 | (symbol-to-js (d-name defun))) | |
597 | :end ") {" :join-after ",")) | |
598 | (fun-body (js-to-statement-strings (d-body defun) (+ start-pos 2)))) | |
599 | (nconc fun-header fun-body (list "}")))) | |
600 | ||
601 | (defmethod js-to-statement-strings ((defun js-defun) start-pos) | |
602 | (js-to-strings defun start-pos)) | |
603 | ||
604 | (defjsmacro lambda (args &rest body) | |
605 | `(defun :|| ,args ,@body)) | |
606 | ||
607 | ;;; object creation | |
608 | ||
609 | (defclass js-object (expression) | |
610 | ((slots :initarg :slots | |
611 | :accessor o-slots))) | |
612 | ||
613 | (define-js-compiler-macro create (&rest args) | |
614 | (make-instance 'js-object | |
615 | :slots (loop for (name val) on args by #'cddr | |
616 | collect (list (js-compile-to-symbol name) | |
617 | (js-compile-to-expression val))))) | |
618 | ||
619 | ;;; XXX so ist das noch nicht korrekt | |
620 | (defmethod js-to-strings ((object js-object) start-pos) | |
621 | (let ((value-string-lists | |
622 | (mapcar #'(lambda (slot) | |
623 | (dwim-join (list (js-to-strings (second slot) (+ start-pos 4))) | |
624 | (- 80 start-pos 2) | |
625 | :start (concatenate 'string (symbol-to-js (first slot)) " : ") | |
626 | :white-space " ")) (o-slots object))) | |
627 | (max-length (- 80 start-pos 2))) | |
628 | (dwim-join value-string-lists max-length | |
629 | :start (format nil "{~% ") | |
630 | :end (format nil "~%} ") | |
631 | :join-after ", " | |
632 | :white-space " " | |
633 | :collect nil))) | |
634 | ||
635 | (defclass js-slot-value (expression) | |
636 | ((object :initarg :object | |
637 | :accessor sv-object) | |
638 | (slot :initarg :slot | |
639 | :accessor sv-slot))) | |
640 | ||
641 | (define-js-compiler-macro slot-value (obj slot) | |
642 | (make-instance 'js-slot-value :object (js-compile-to-expression obj) | |
643 | :slot (js-compile-to-symbol slot))) | |
644 | ||
645 | (defmethod js-to-strings ((sv js-slot-value) start-pos) | |
646 | (append-to-last (js-to-strings (sv-object sv) start-pos) | |
647 | (format nil ".~A" (symbol-to-js (sv-slot sv))))) | |
648 | ||
649 | (defjsmacro with-slots (slots object &rest body) | |
650 | `(symbol-macrolet ,(mapcar #'(lambda (slot) | |
651 | `(,slot '(slot-value ,object ',slot))) | |
652 | slots) | |
653 | ,@body)) | |
654 | ||
655 | ;;; macros | |
656 | ||
657 | (define-js-compiler-macro macrolet (macros &rest body) | |
658 | (let* ((macro-env (make-hash-table)) | |
659 | (*js-macro-env* (cons macro-env *js-macro-env*))) | |
660 | (dolist (macro macros) | |
661 | (destructuring-bind (name arglist &rest body) macro | |
662 | (setf (gethash name macro-env) | |
663 | (compile nil `(lambda ,arglist ,@body))))) | |
664 | (js-compile `(progn ,@body)))) | |
665 | ||
666 | (defjsmacro symbol-macrolet (macros &rest body) | |
667 | `(macrolet ,(mapcar #'(lambda (macro) | |
668 | `(,(first macro) () ,@(rest macro))) macros) | |
669 | ,@body)) | |
670 | ||
671 | ;;; lisp eval | |
672 | ||
673 | (defjsmacro lisp (&rest forms) | |
674 | (eval (cons 'progn forms))) | |
675 | ||
676 | ;;; if | |
677 | ||
678 | (defclass js-if (expression) | |
679 | ((test :initarg :test | |
680 | :accessor if-test) | |
681 | (then :initarg :then | |
682 | :accessor if-then) | |
683 | (else :initarg :else | |
684 | :accessor if-else))) | |
685 | ||
686 | (define-js-compiler-macro if (test then &optional else) | |
687 | (make-instance 'js-if :test (js-compile-to-expression test) | |
688 | :then (js-compile-to-body then :indent " ") | |
689 | :else (when else | |
690 | (js-compile-to-body else :indent " ")))) | |
691 | ||
692 | (defmethod js-to-statement-strings ((if js-if) start-pos) | |
693 | (let ((if-strings (dwim-join (list (js-to-strings (if-test if) 0)) | |
694 | (- 80 start-pos 2) | |
695 | :start "if (" | |
696 | :end ") {")) | |
697 | (then-strings (js-to-statement-strings (if-then if) (+ start-pos 2))) | |
698 | (else-strings (when (if-else if) | |
699 | (js-to-statement-strings (if-else if) | |
700 | (+ start-pos 2))))) | |
701 | (nconc if-strings then-strings (if else-strings | |
702 | (nconc (list "} else {") else-strings (list "}")) | |
703 | (list "}"))))) | |
704 | ||
705 | (defmethod expression-precedence ((if js-if)) | |
706 | (gethash 'if *op-precedence-hash*)) | |
707 | ||
708 | (defmethod js-to-strings ((if js-if) start-pos) | |
709 | (assert (typep (if-then if) 'expression)) | |
710 | (when (if-else if) | |
711 | (assert (typep (if-else if) 'expression))) | |
712 | (dwim-join (list (append-to-last (js-to-strings (if-test if) start-pos) " ?") | |
713 | (let* ((new-then (make-instance 'js-body | |
714 | :stmts (b-stmts (if-then if)) | |
715 | :indent "")) | |
716 | (res (js-to-strings new-then start-pos))) | |
717 | (if (>= (expression-precedence (if-then if)) | |
718 | (expression-precedence if)) | |
719 | (klammer res) | |
720 | res)) | |
721 | (list ":") | |
722 | (if (if-else if) | |
723 | (let* ((new-else (make-instance 'js-body | |
724 | :stmts (b-stmts (if-else if)) | |
725 | :indent "")) | |
726 | (res (js-to-strings new-else start-pos))) | |
727 | (if (>= (expression-precedence (if-else if)) | |
728 | (expression-precedence if)) | |
729 | (klammer res) | |
730 | res)) | |
731 | (list "undefined"))) | |
732 | (- 80 start-pos 2) | |
733 | :white-space " ")) | |
734 | ||
735 | (defjsmacro when (test &rest body) | |
736 | `(if ,test (progn ,@body))) | |
737 | ||
738 | (defjsmacro unless (test &rest body) | |
739 | `(if (not ,test) (progn ,@body))) | |
740 | ||
741 | ;;; single keyword expressions and statements | |
742 | ||
743 | (defmacro define-js-single-op (name &optional (superclass 'expression)) | |
744 | (let ((js-name (intern (concatenate 'string "JS-" (symbol-name name)) #.*package*))) | |
745 | `(progn | |
746 | (defclass ,js-name (,superclass) | |
747 | ()) | |
748 | (define-js-compiler-macro ,name (value) | |
749 | (make-instance ',js-name :value (js-compile-to-expression value))) | |
750 | (defmethod js-to-strings ((,name ,js-name) start-pos) | |
751 | (dwim-join (list (js-to-strings (value ,name) (+ start-pos 2))) | |
752 | (- 80 start-pos 2) | |
753 | :start ,(concatenate 'string (string-downcase (symbol-name name)) " ") | |
754 | :white-space " "))))) | |
755 | ||
756 | ||
757 | (define-js-single-op return statement) | |
758 | (define-js-single-op throw statement) | |
759 | (define-js-single-op delete) | |
760 | (define-js-single-op void) | |
761 | (define-js-single-op typeof) | |
762 | (define-js-single-op instanceof) | |
763 | (define-js-single-op new) | |
764 | ||
765 | ;;; assignment | |
766 | ||
767 | (defclass js-setf (expression) | |
768 | ((lhs :initarg :lhs :accessor setf-lhs) | |
769 | (rhsides :initarg :rhsides :accessor setf-rhsides))) | |
770 | ||
771 | (define-js-compiler-macro setf (&rest args) | |
772 | (let ((assignments (loop for (lhs rhs) on args by #'cddr | |
773 | for rexpr = (js-compile-to-expression rhs) | |
774 | for lexpr = (js-compile-to-expression lhs) | |
775 | collect (make-instance 'js-setf :lhs lexpr | |
776 | :rhsides (list rexpr))))) | |
777 | (if (= (length assignments) 1) | |
778 | (first assignments) | |
779 | (make-instance 'js-body :indent "" :stmts assignments)))) | |
780 | ||
781 | (defmethod js-to-strings ((setf js-setf) start-pos) | |
782 | (dwim-join (cons (js-to-strings (setf-lhs setf) start-pos) | |
783 | (mapcar #'(lambda (x) (js-to-strings x start-pos)) (setf-rhsides setf))) | |
784 | (- 80 start-pos 2) | |
785 | :join-after " =")) | |
786 | ||
787 | (defmethod expression-precedence ((setf js-setf)) | |
788 | (gethash '= *op-precedence-hash*)) | |
789 | ||
790 | ;;; defvar | |
791 | ||
792 | (defclass js-defvar (statement) | |
793 | ((names :initarg :names :accessor var-names) | |
794 | (value :initarg :value :accessor var-value))) | |
795 | ||
796 | (define-js-compiler-macro defvar (name &optional value) | |
797 | (make-instance 'js-defvar :names (list (js-compile-to-symbol name)) | |
798 | :value (when value (js-compile-to-expression value)))) | |
799 | ||
800 | (defmethod js-to-statement-strings ((defvar js-defvar) start-pos) | |
801 | (dwim-join (nconc (mapcar #'(lambda (x) (list (symbol-to-js x))) (var-names defvar)) | |
802 | (when (var-value defvar) | |
803 | (list (js-to-strings (var-value defvar) start-pos)))) | |
804 | (- 80 start-pos 2) | |
805 | :join-after " =" | |
806 | :start "var " :end ";")) | |
807 | ||
808 | ;;; let | |
809 | ||
810 | (define-js-compiler-macro let (decls &rest body) | |
811 | (let ((single-defvar (make-instance 'js-defvar | |
812 | :names (mapcar #'js-compile-to-symbol | |
813 | (remove-if-not #'atom decls)) | |
814 | :value nil)) | |
815 | (defvars (mapcar #'(lambda (decl) | |
816 | (let ((name (first decl)) | |
817 | (value (second decl))) | |
818 | (make-instance 'js-defvar | |
819 | :names (list (js-compile-to-symbol name)) | |
820 | :value (js-compile-to-expression value)))) | |
821 | (remove-if #'atom decls)))) | |
822 | (make-instance 'js-sub-body | |
823 | :indent " " | |
824 | :stmts (nconc (when (var-names single-defvar) (list single-defvar)) | |
825 | defvars | |
826 | (mapcar #'js-compile-to-statement body))))) | |
551080b7 | 827 | |
8e198a08 MB |
828 | ;;; iteration |
829 | ||
830 | (defclass js-for (statement) | |
831 | ((vars :initarg :vars :accessor for-vars) | |
832 | (steps :initarg :steps :accessor for-steps) | |
833 | (check :initarg :check :accessor for-check) | |
834 | (body :initarg :body :accessor for-body))) | |
835 | ||
836 | (defun make-for-vars (decls) | |
837 | (loop for decl in decls | |
838 | for var = (if (atom decl) decl (first decl)) | |
839 | for init = (if (atom decl) nil (second decl)) | |
840 | collect (make-instance 'js-defvar :names (list (js-compile-to-symbol var)) | |
841 | :value (js-compile-to-expression init)))) | |
842 | ||
843 | (defun make-for-steps (decls) | |
844 | (loop for decl in decls | |
845 | when (= (length decl) 3) | |
846 | collect (js-compile-to-expression (third decl)))) | |
847 | ||
848 | (define-js-compiler-macro do (decls termination &rest body) | |
849 | (let ((vars (make-for-vars decls)) | |
850 | (steps (make-for-steps decls)) | |
851 | (check (js-compile-to-expression (list 'not (first termination)))) | |
852 | (body (js-compile-to-body (cons 'progn body) :indent " "))) | |
853 | (make-instance 'js-for | |
854 | :vars vars | |
855 | :steps steps | |
856 | :check check | |
857 | :body body))) | |
858 | ||
859 | (defun strings-length (string-list) | |
860 | (reduce #'max (mapcar #'length string-list) :initial-value most-negative-fixnum)) | |
861 | ||
862 | (defmethod js-to-statement-strings ((for js-for) start-pos) | |
863 | (let* ((init (dwim-join (mapcar #'(lambda (x) | |
864 | (dwim-join (list (list (symbol-to-js (first (var-names x)))) | |
865 | (js-to-strings (var-value x) | |
866 | (+ start-pos 2))) | |
867 | (- 80 start-pos 2) | |
868 | :join-after " =")) | |
869 | (for-vars for)) | |
870 | (- 80 start-pos 2) | |
871 | :start "var " :join-after ",")) | |
872 | #+nil | |
873 | (init-len (strings-length init)) | |
874 | (check (js-to-strings (for-check for) (+ start-pos 2))) | |
875 | #+nil | |
876 | (check-len (strings-length check)) | |
877 | (steps (dwim-join (mapcar #'(lambda (x) | |
878 | (js-to-strings x (- start-pos 2))) | |
879 | (for-steps for)) | |
880 | (- 80 start-pos 2) | |
881 | :join-after ",")) | |
882 | (header (dwim-join (list init check steps) | |
883 | (- 80 start-pos 2) | |
884 | :start "for (" :end ") {" | |
885 | :join-after ";")) | |
886 | (body (js-to-statement-strings (for-body for) (+ start-pos 2)))) | |
887 | (nconc header body (list "}")))) | |
888 | ||
889 | (let ((fun-header (dwim-join (mapcar #'(lambda (x) (list (symbol-to-js x))) | |
890 | (d-args defun)) | |
891 | (- 80 start-pos 2) | |
892 | :start (format nil "function ~A(" | |
893 | (symbol-to-js (d-name defun))) | |
894 | :end ") {" :join-after ",")) | |
895 | (fun-body (js-to-statement-strings (d-body defun) (+ start-pos 2)))) | |
896 | (nconc fun-header fun-body (list "}")))) | |
897 | ||
898 | (defclass for-each (statement) | |
899 | ((name :initarg :name :accessor fe-name) | |
900 | (value :initarg :value :accessor fe-value) | |
901 | (body :initarg :value :accessor fe-body))) | |
902 | ||
903 | (define-js-compiler-macro do-each (decl &rest body) | |
904 | (make-instance 'for-each :name (js-compile-to-symbol (first decl)) | |
905 | :value (js-compile-to-expression (second decl)) | |
906 | :body (js-compile-to-body (cons 'progn body) :indent " "))) | |
907 | ||
908 | (defmethod js-to-statement-strings ((fe for-each) start-pos) | |
909 | (let ((header (dwim-join (list (list (symbol-to-js (fe-name fe)) " in ") | |
910 | (js-to-strings (fe-value fe) (+ start-pos 2))) | |
911 | :start "for (var " | |
912 | :end ") {")) | |
913 | (body (js-to-statement-strings (fe-body fe) (+ start-pos 2)))) | |
914 | (nconc header body (list "}")))) | |
915 | ||
916 | (defclass js-while (statement) | |
917 | ((check :initarg :check :accessor while-check) | |
918 | (body :initarg :body :accessor while-body))) | |
919 | ||
920 | (define-js-compiler-macro while (check &rest body) | |
921 | (make-instance 'js-while | |
922 | :check (js-compile-to-expression check) | |
923 | :body (js-compile-to-body (cons 'progn body) :indent " "))) | |
924 | ||
925 | (defmethod js-to-statement-strings ((while js-while) start-pos) | |
926 | (let ((header (dwim-join (list (js-to-strings (while-check while) (+ start-pos 2))) | |
927 | (- 80 start-pos 2) | |
928 | :start "while (" | |
929 | :end ") {")) | |
930 | (body (js-to-statement-strings (while-body while) (+ start-pos 2)))) | |
931 | (nconc header body (list "}")))) | |
932 | ||
933 | ;;; with | |
934 | ||
935 | (defclass js-with (statement) | |
936 | ((obj :initarg :obj :accessor with-obj) | |
937 | (body :initarg :body :accessor with-body))) | |
938 | ||
939 | (define-js-compiler-macro with (statement &rest body) | |
940 | (make-instance 'js-with | |
941 | :obj (js-compile-to-expression (first statement)) | |
942 | :body (js-compile-to-body (cons 'progn body) :indent " "))) | |
943 | ||
944 | (defmethod js-to-statement-strings ((with js-with) start-pos) | |
945 | (nconc (dwim-join (list (js-to-strings (with-obj with) (+ start-pos 2))) | |
946 | (- 80 start-pos 2) | |
947 | :start "with (" :end ") {") | |
948 | (js-to-statement-strings (with-body with) (+ start-pos 2)) | |
949 | (list "}"))) | |
950 | ||
951 | ;;; case | |
952 | ||
953 | (defclass js-case (statement) | |
954 | ((value :initarg :value :accessor case-value) | |
955 | (clauses :initarg :clauses :accessor case-clauses))) | |
956 | ||
957 | ;;; XXX DEFAULT exporten | |
958 | (define-js-compiler-macro case (value &rest clauses) | |
959 | (let ((clauses (mapcar #'(lambda (clause) | |
960 | (let ((val (first clause)) | |
961 | (body (cdr clause))) | |
962 | (list (if (eql val 'default) | |
963 | 'default | |
964 | (js-compile-to-expression val)) | |
965 | (js-compile-to-body (cons 'progn body) :indent " ")))) | |
966 | clauses)) | |
967 | (check (js-compile-to-expression value))) | |
968 | (make-instance 'js-case :value check | |
969 | :clauses clauses))) | |
970 | ||
971 | (defmethod js-to-statement-strings ((case js-case) start-pos) | |
972 | (let ((body (mapcan #'(lambda (clause) | |
973 | (let ((val (car clause)) | |
974 | (body (second clause))) | |
975 | (dwim-join (list (if (eql val 'default) | |
976 | (list "") | |
977 | (js-to-strings val (+ start-pos 2))) | |
978 | (js-to-statement-strings body (+ start-pos 2))) | |
979 | (- 80 start-pos 2) | |
980 | :start (if (eql val 'default) " default" " case ") | |
981 | :white-space " " | |
982 | :join-after ":"))) (case-clauses case)))) | |
983 | ||
984 | (format t "body: ~S~%" body) | |
985 | (nconc (dwim-join (list (js-to-strings (case-value case) (+ start-pos 2))) | |
986 | (- 80 start-pos 2) | |
987 | :start "switch (" :end ") {") | |
988 | body | |
989 | (list "}")))) | |
990 | ||
991 | ;;; throw catch | |
992 | ||
993 | (defclass js-try (statement) | |
994 | ((body :initarg :body :accessor try-body) | |
995 | (catch :initarg :catch :accessor try-catch) | |
996 | (finally :initarg :finally :accessor try-finally))) | |
997 | ||
998 | (define-js-compiler-macro try (body clauses) | |
999 | (let ((body (js-compile-to-body body :indent " ")) | |
1000 | (catch (cdr (assoc :catch clauses))) | |
1001 | (finally (cdr (assoc :finally clauses)))) | |
1002 | (make-instance 'js-try | |
1003 | :body body | |
1004 | :catch (when catch (list (js-compile-to-symbol (first catch)) | |
1005 | (js-compile-to-body (cons 'progn (cdr catch)) | |
1006 | :indent " "))) | |
1007 | :finally (when finally (js-compile-to-body finally :indent " "))))) | |
1008 | ||
1009 | (defmethod js-to-statement-strings ((try js-try) start-pos) | |
1010 | (let* ((catch (try-catch try)) | |
1011 | (finally (try-finally try)) | |
1012 | (catch-list (when catch | |
1013 | (dwim-join (list (list (symbol-to-js (first catch))) | |
1014 | (js-to-strings (second catch) (+ start-pos 2))) | |
1015 | (- 80 start-pos 2) | |
1016 | :start "} catch (" | |
1017 | :end ") {"))) | |
1018 | (finally-list (when finally | |
1019 | (dwim-join (list (js-to-strings finally (+ start-pos 2))) | |
1020 | (- 80 start-pos 2) | |
1021 | :start "finally {")))) | |
1022 | (nconc (dwim-join (list (js-to-statement-strings (try-body try) (+ start-pos 2))) | |
1023 | (- 80 start-pos 2) | |
1024 | :start "try {") | |
1025 | catch-list | |
1026 | finally-list | |
1027 | (list "}")))) | |
1028 | ||
1029 | ;;; regex | |
1030 | ||
1031 | (defclass regex (expression) | |
1032 | ()) | |
1033 | ||
1034 | (define-js-compiler-macro regex (regex) | |
1035 | (make-instance 'regex :value (string regex))) | |
1036 | ||
1037 | ;;; conditional compilation | |
1038 | ||
1039 | (defclass cc-if () | |
1040 | ((test :initarg :test :accessor cc-if-test) | |
1041 | (body :initarg :body :accessor cc-if-body))) | |
1042 | ||
1043 | (defmethod js-to-statement-strings ((cc cc-if) start-pos) | |
1044 | (nconc (list (format nil "/*@if ~A" (cc-if-test cc))) | |
1045 | (mapcan #'(lambda (x) (js-to-strings x start-pos)) (cc-if-body cc)) | |
1046 | (list "@end @*/"))) | |
1047 | ||
1048 | (define-js-compiler-macro cc-if (test &rest body) | |
1049 | (make-instance 'cc-if :test test | |
1050 | :body (mapcar #'js-compile body))) | |
1051 | ||
1052 | ;;; compiler | |
1053 | ||
1054 | (defun js-compile (form) | |
1055 | (setf form (js-expand-form form)) | |
1056 | (cond ((stringp form) | |
1057 | (make-instance 'string-literal :value form)) | |
1058 | ((numberp form) | |
1059 | (make-instance 'number-literal :value form)) | |
1060 | ((symbolp form) | |
1061 | (let ((c-macro (js-get-compiler-macro form))) | |
1062 | (if c-macro | |
1063 | (funcall c-macro) | |
1064 | (make-instance 'js-variable :value form)))) | |
1065 | ((and (consp form) | |
1066 | (eql (first form) 'quote)) | |
1067 | (second form)) | |
1068 | ((consp form) | |
1069 | (js-compile-list form)) | |
1070 | (t (error "Unknown atomar expression ~S" form)))) | |
1071 | ||
1072 | (defun js-compile-list (form) | |
1073 | (let* ((name (car form)) | |
1074 | (args (cdr form)) | |
1075 | (js-form (js-get-compiler-macro name))) | |
1076 | (cond (js-form | |
1077 | (apply js-form args)) | |
1078 | ||
1079 | ((op-form-p form) | |
1080 | (make-instance 'op-form | |
1081 | :operator (js-convert-op-name (first form)) | |
1082 | :args (mapcar #'js-compile-to-expression (rest form)))) | |
1083 | ||
1084 | ((method-call-p form) | |
1085 | (make-instance 'method-call | |
1086 | :method (first form) | |
1087 | :args (mapcar #'js-compile-to-expression (rest form)))) | |
1088 | ||
1089 | ((funcall-form-p form) | |
1090 | (make-instance 'function-call | |
1091 | :function (first form) | |
1092 | :args (mapcar #'js-compile-to-expression (rest form)))) | |
1093 | ||
1094 | (t (error "Unknown form ~S" form))))) | |
1095 | ||
1096 | (defun js-compile-to-expression (form) | |
1097 | (let ((res (js-compile form))) | |
1098 | (assert (typep res 'expression)) | |
1099 | res)) | |
1100 | ||
1101 | (defun js-compile-to-symbol (form) | |
1102 | (let ((res (js-compile form))) | |
1103 | (when (typep res 'js-variable ) | |
1104 | (setf res (value res))) | |
1105 | (assert (symbolp res)) | |
1106 | res)) | |
1107 | ||
1108 | (defun js-compile-to-statement (form) | |
1109 | (let ((res (js-compile form))) | |
1110 | (assert (typep res 'statement)) | |
1111 | res)) | |
1112 | ||
1113 | (defun js-compile-to-body (form &key (indent "")) | |
1114 | (let ((res (js-compile-to-statement form))) | |
1115 | (if (typep res 'js-body) | |
1116 | (progn (setf (b-indent res) indent) | |
1117 | res) | |
1118 | (make-instance 'js-body | |
1119 | :indent indent | |
1120 | :stmts (list res))))) |