Commit | Line | Data |
---|---|---|
5aa10005 RD |
1 | (in-package :parenscript.javascript) |
2 | ||
3 | ;;;; The macrology of the basic Javascript-in-SEXPs language. Special forms and macros. | |
4 | ||
5 | ;;; literals | |
6 | (defmacro defscriptliteral (name string) | |
7 | "Define a Javascript literal that will expand to STRING." | |
8 | `(define-script-special-form ,name () (make-instance 'expression :value ,string))) | |
9 | ||
10 | (defscriptliteral this "this") | |
11 | (defscriptliteral t "true") | |
171bbab3 | 12 | (defscriptliteral true "true") |
5aa10005 | 13 | (defscriptliteral false "false") |
171bbab3 RD |
14 | (defscriptliteral f "false") |
15 | (defscriptliteral nil "null") | |
5aa10005 RD |
16 | (defscriptliteral undefined "undefined") |
17 | ||
18 | (defmacro defscriptkeyword (name string) | |
19 | "Define a Javascript keyword that will expand to STRING." | |
20 | `(define-script-special-form ,name () (make-instance 'statement :value ,string))) | |
21 | ||
22 | (defscriptkeyword break "break") | |
23 | (defscriptkeyword continue "continue") | |
24 | ||
25 | ;;; array literals | |
26 | (define-script-special-form array (&rest values) | |
27 | (make-instance 'array-literal | |
28 | :values (mapcar #'compile-to-expression values))) | |
29 | ||
30 | (define-script-special-form aref (array &rest coords) | |
31 | (make-instance 'js-aref | |
32 | :array (compile-to-expression array) | |
33 | :index (mapcar #'compile-to-expression coords))) | |
34 | ||
35 | ||
36 | ;;; object literals (maps and hash-tables) | |
37 | (define-script-special-form {} (&rest values) | |
38 | (make-instance 'object-literal | |
39 | :values (loop | |
40 | for (key value) on values by #'cddr | |
41 | collect (cons key (compile-to-expression value))))) | |
42 | ||
43 | ;;; operators | |
44 | (define-script-special-form ++ (x) | |
45 | (make-instance 'one-op :pre-p nil :op "++" | |
46 | :value (compile-to-expression x))) | |
47 | ||
48 | (define-script-special-form -- (x) | |
49 | (make-instance 'one-op :pre-p nil :op "--" | |
50 | :value (compile-to-expression x))) | |
51 | ||
52 | (define-script-special-form incf (x &optional (delta 1)) | |
53 | (if (eql delta 1) | |
54 | (make-instance 'one-op :pre-p t :op "++" | |
55 | :value (compile-to-expression x)) | |
56 | (make-instance 'op-form | |
57 | :operator '+= | |
58 | :args (mapcar #'compile-to-expression | |
59 | (list x delta ))))) | |
60 | ||
61 | (define-script-special-form decf (x &optional (delta 1)) | |
62 | (if (eql delta 1) | |
63 | (make-instance 'one-op :pre-p t :op "--" | |
64 | :value (compile-to-expression x)) | |
65 | (make-instance 'op-form | |
66 | :operator '-= | |
67 | :args (mapcar #'compile-to-expression | |
68 | (list x delta ))))) | |
69 | ||
70 | (define-script-special-form - (first &rest rest) | |
71 | (if (null rest) | |
72 | (make-instance 'one-op | |
73 | :pre-p t | |
74 | :op "-" | |
75 | :value (compile-to-expression first)) | |
76 | (make-instance 'op-form | |
77 | :operator '- | |
78 | :args (mapcar #'compile-to-expression | |
79 | (cons first rest))))) | |
80 | ||
81 | (define-script-special-form not (x) | |
82 | (let ((value (compile-to-expression x))) | |
83 | (if (and (typep value 'op-form) | |
84 | (= (length (op-args value)) 2)) | |
85 | (let ((new-op (case (operator value) | |
86 | (== '!=) | |
87 | (< '>=) | |
88 | (> '<=) | |
89 | (<= '>) | |
90 | (>= '<) | |
91 | (!= '==) | |
92 | (=== '!==) | |
93 | (!== '===) | |
94 | (t nil)))) | |
95 | (if new-op | |
96 | (make-instance 'op-form :operator new-op | |
97 | :args (op-args value)) | |
98 | (make-instance 'one-op :pre-p t :op "!" | |
99 | :value value))) | |
100 | (make-instance 'one-op :pre-p t :op "!" | |
101 | :value value)))) | |
102 | ||
103 | (define-script-special-form ~ (x) | |
104 | (let ((expr (compile-to-expression x))) | |
105 | (make-instance 'one-op :pre-p t :op "~" :value expr))) | |
106 | ||
107 | ;;; progn | |
108 | (define-script-special-form progn (&rest body) | |
109 | (make-instance 'js-block | |
110 | :statements (mapcar #'compile-to-statement body))) | |
111 | ||
112 | (defmethod expression-precedence ((body js-block)) | |
113 | (if (= (length (block-statements body)) 1) | |
114 | (expression-precedence (first (block-statements body))) | |
115 | (op-precedence 'comma))) | |
116 | ||
117 | ;;; function definition | |
118 | (define-script-special-form lambda (args &rest body) | |
119 | (make-instance 'js-lambda | |
120 | :args (mapcar #'compile-to-symbol args) | |
121 | :body (make-instance 'js-block | |
122 | :indent " " | |
123 | :statements (mapcar #'compile-to-statement body)))) | |
124 | ||
125 | (define-script-special-form defun (name args &rest body) | |
126 | (make-instance 'js-defun | |
127 | :name (compile-to-symbol name) | |
128 | :args (mapcar #'compile-to-symbol args) | |
129 | :body (make-instance 'js-block | |
130 | :indent " " | |
131 | :statements (mapcar #'compile-to-statement body)))) | |
132 | ||
133 | ;;; object creation | |
134 | (define-script-special-form create (&rest args) | |
135 | (make-instance 'js-object | |
136 | :slots (loop for (name val) on args by #'cddr | |
137 | collect (let ((name-expr (compile-to-expression name))) | |
138 | (assert (or (typep name-expr 'js-variable) | |
139 | (typep name-expr 'string-literal) | |
140 | (typep name-expr 'number-literal))) | |
141 | (list name-expr (compile-to-expression val)))))) | |
142 | ||
143 | ||
144 | (define-script-special-form slot-value (obj slot) | |
145 | (make-instance 'js-slot-value :object (compile-to-expression obj) | |
146 | :slot (compile-script-form slot))) | |
147 | ||
148 | ;;; cond | |
149 | (define-script-special-form cond (&rest clauses) | |
150 | (make-instance 'js-cond | |
151 | :tests (mapcar (lambda (clause) (compile-to-expression (car clause))) | |
152 | clauses) | |
153 | :bodies (mapcar (lambda (clause) (compile-to-block (cons 'progn (cdr clause)) :indent " ")) | |
154 | clauses))) | |
155 | ||
156 | ;;; if | |
157 | (define-script-special-form if (test then &optional else) | |
158 | (make-instance 'js-if :test (compile-to-expression test) | |
159 | :then (compile-to-block then :indent " ") | |
160 | :else (when else | |
161 | (compile-to-block else :indent " ")))) | |
162 | ||
163 | (defmethod expression-precedence ((if js-if)) | |
164 | (op-precedence 'if)) | |
165 | ||
166 | ;;; switch | |
167 | (define-script-special-form switch (value &rest clauses) | |
168 | (let ((clauses (mapcar #'(lambda (clause) | |
169 | (let ((val (first clause)) | |
170 | (body (cdr clause))) | |
171 | (list (if (eql val 'default) | |
172 | 'default | |
173 | (compile-to-expression val)) | |
174 | (compile-to-block (cons 'progn body) :indent " ")))) | |
175 | clauses)) | |
176 | (check (compile-to-expression value))) | |
177 | (make-instance 'js-switch :value check | |
178 | :clauses clauses))) | |
179 | ||
180 | ||
181 | ;;; assignment | |
182 | (defun assignment-op (op) | |
183 | (case op | |
184 | (+ '+=) | |
185 | (~ '~=) | |
186 | (\& '\&=) | |
187 | (\| '\|=) | |
188 | (- '-=) | |
189 | (* '*=) | |
190 | (% '%=) | |
191 | (>> '>>=) | |
192 | (^ '^=) | |
193 | (<< '<<=) | |
194 | (>>> '>>>=) | |
195 | (/ '/=) | |
196 | (t nil))) | |
197 | ||
198 | (defun make-js-test (lhs rhs) | |
199 | (if (and (typep rhs 'op-form) | |
7590646c | 200 | (member lhs (op-args rhs) :test #'script-equal)) |
5aa10005 | 201 | (let ((args-without (remove lhs (op-args rhs) |
7590646c | 202 | :count 1 :test #'script-equal)) |
5aa10005 RD |
203 | (args-without-first (remove lhs (op-args rhs) |
204 | :count 1 :end 1 | |
7590646c | 205 | :test #'script-equal)) |
5aa10005 RD |
206 | (one (list (make-instance 'number-literal :value 1)))) |
207 | #+nil | |
208 | (format t "OPERATOR: ~S, ARGS-WITHOUT: ~S, ARGS-WITHOUT-FIRST ~S~%" | |
209 | (operator rhs) | |
210 | args-without | |
211 | args-without-first) | |
7590646c | 212 | (cond ((and (script-equal args-without one) |
5aa10005 RD |
213 | (eql (operator rhs) '+)) |
214 | (make-instance 'one-op :pre-p nil :op "++" | |
215 | :value lhs)) | |
7590646c | 216 | ((and (script-equal args-without-first one) |
5aa10005 RD |
217 | (eql (operator rhs) '-)) |
218 | (make-instance 'one-op :pre-p nil :op "--" | |
219 | :value lhs)) | |
220 | ((and (assignment-op (operator rhs)) | |
221 | (member (operator rhs) | |
222 | '(+ *)) | |
7590646c | 223 | (script-equal lhs (first (op-args rhs)))) |
5aa10005 RD |
224 | (make-instance 'op-form |
225 | :operator (assignment-op (operator rhs)) | |
226 | :args (list lhs (make-instance 'op-form | |
227 | :operator (operator rhs) | |
228 | :args args-without-first)))) | |
229 | ((and (assignment-op (operator rhs)) | |
7590646c | 230 | (script-equal (first (op-args rhs)) lhs)) |
5aa10005 RD |
231 | (make-instance 'op-form |
232 | :operator (assignment-op (operator rhs)) | |
233 | :args (list lhs (make-instance 'op-form | |
234 | :operator (operator rhs) | |
235 | :args (cdr (op-args rhs)))))) | |
236 | (t (make-instance 'js-setf :lhs lhs :rhsides (list rhs))))) | |
237 | (make-instance 'js-setf :lhs lhs :rhsides (list rhs)))) | |
238 | ||
239 | (define-script-special-form setf (&rest args) | |
240 | (let ((assignments (loop for (lhs rhs) on args by #'cddr | |
241 | for rexpr = (compile-to-expression rhs) | |
242 | for lexpr = (compile-to-expression lhs) | |
243 | collect (make-js-test lexpr rexpr)))) | |
244 | (if (= (length assignments) 1) | |
245 | (first assignments) | |
246 | (make-instance 'js-block :indent "" :statements assignments)))) | |
247 | ||
248 | (defmethod expression-precedence ((setf js-setf)) | |
249 | (op-precedence '=)) | |
250 | ||
251 | ;;; defvar | |
252 | (define-script-special-form defvar (name &optional value) | |
253 | (make-instance 'js-defvar :names (list (compile-to-symbol name)) | |
254 | :value (when value (compile-to-expression value)))) | |
255 | ||
256 | ;;; iteration | |
257 | (defun make-for-vars (decls) | |
258 | (loop for decl in decls | |
259 | for var = (if (atom decl) decl (first decl)) | |
260 | for init = (if (atom decl) nil (second decl)) | |
261 | collect (make-instance 'js-defvar :names (list (compile-to-symbol var)) | |
262 | :value (compile-to-expression init)))) | |
263 | ||
264 | (defun make-for-steps (decls) | |
265 | (loop for decl in decls | |
266 | when (= (length decl) 3) | |
267 | collect (compile-to-expression (third decl)))) | |
268 | ||
269 | (define-script-special-form do (decls termination &rest body) | |
270 | (let ((vars (make-for-vars decls)) | |
271 | (steps (make-for-steps decls)) | |
272 | (check (compile-to-expression (list 'not (first termination)))) | |
273 | (body (compile-to-block (cons 'progn body) :indent " "))) | |
274 | (make-instance 'js-for | |
275 | :vars vars | |
276 | :steps steps | |
277 | :check check | |
278 | :body body))) | |
279 | ||
280 | (define-script-special-form doeach (decl &rest body) | |
281 | (make-instance 'for-each :name (compile-to-symbol (first decl)) | |
282 | :value (compile-to-expression (second decl)) | |
283 | :body (compile-to-block (cons 'progn body) :indent " "))) | |
284 | ||
285 | (define-script-special-form while (check &rest body) | |
286 | (make-instance 'js-while | |
287 | :check (compile-to-expression check) | |
288 | :body (compile-to-block (cons 'progn body) :indent " "))) | |
289 | ||
290 | ;;; with | |
291 | (define-script-special-form with (statement &rest body) | |
292 | (make-instance 'js-with | |
293 | :obj (compile-to-expression statement) | |
294 | :body (compile-to-block (cons 'progn body) :indent " "))) | |
295 | ||
296 | ||
297 | ;;; try-catch | |
298 | (define-script-special-form try (body &rest clauses) | |
299 | (let ((body (compile-to-block body :indent " ")) | |
300 | (catch (cdr (assoc :catch clauses))) | |
301 | (finally (cdr (assoc :finally clauses)))) | |
302 | (assert (not (cdar catch)) nil "Sorry, currently only simple catch forms are supported.") | |
303 | (make-instance 'js-try | |
304 | :body body | |
305 | :catch (when catch (list (compile-to-symbol (caar catch)) | |
306 | (compile-to-block (cons 'progn (cdr catch)) | |
307 | :indent " "))) | |
308 | :finally (when finally (compile-to-block (cons 'progn finally) | |
309 | :indent " "))))) | |
310 | ;;; regex | |
311 | (define-script-special-form regex (regex) | |
312 | (make-instance 'regex :value (string regex))) | |
313 | ||
314 | ;;; TODO instanceof | |
315 | (define-script-special-form instanceof (value type) | |
316 | (make-instance 'js-instanceof | |
317 | :value (compile-to-expression value) | |
318 | :type (compile-to-expression type))) | |
319 | ||
320 | ;;; single operations | |
321 | (defmacro define-parse-script-single-op (name &optional (superclass 'expression)) | |
322 | (let ((script-name (intern (concatenate 'string "JS-" (symbol-name name)) #.*package*))) | |
323 | `(define-script-special-form ,name (value) | |
324 | (make-instance ',script-name :value (compile-to-expression value))) | |
325 | )) | |
326 | ||
327 | (define-parse-script-single-op return statement) | |
328 | (define-parse-script-single-op throw statement) | |
329 | (define-parse-script-single-op delete) | |
330 | (define-parse-script-single-op void) | |
331 | (define-parse-script-single-op typeof) | |
332 | (define-parse-script-single-op new) | |
333 | ||
334 | ;;; conditional compilation | |
335 | (define-script-special-form cc-if (test &rest body) | |
336 | (make-instance 'cc-if :test test | |
337 | :body (mapcar #'compile-script-form body))) | |
338 | ||
339 | ;;; standard macros | |
340 | (defscriptmacro with-slots (slots object &rest body) | |
341 | `(symbol-macrolet ,(mapcar #'(lambda (slot) | |
342 | `(,slot '(slot-value ,object ',slot))) | |
343 | slots) | |
344 | ,@body)) | |
345 | ||
346 | (defscriptmacro when (test &rest body) | |
347 | `(if ,test (progn ,@body))) | |
348 | ||
349 | (defscriptmacro unless (test &rest body) | |
350 | `(if (not ,test) (progn ,@body))) | |
351 | ||
352 | (defscriptmacro 1- (form) | |
353 | `(- ,form 1)) | |
354 | ||
355 | (defscriptmacro 1+ (form) | |
356 | `(+ ,form 1)) | |
357 | ||
5aa10005 RD |
358 | ;;; helper macros |
359 | (define-script-special-form js (&rest body) | |
360 | (make-instance 'string-literal | |
361 | :value (string-join (js-to-statement-strings | |
362 | (compile-script-form (cons 'progn body)) 0) " "))) | |
363 | ||
364 | (define-script-special-form script-inline (&rest body) | |
365 | (make-instance 'string-literal | |
366 | :value (concatenate | |
367 | 'string | |
368 | "javascript:" | |
369 | (string-join (js-to-statement-strings | |
370 | (compile-script-form (cons 'progn body)) 0) " ")))) | |
371 | (defscriptmacro js-inline (&rest body) | |
372 | `(script-inline ,@body)) |