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 | ||
5aa10005 | 107 | (define-script-special-form progn (&rest body) |
72332f2a | 108 | (make-instance 'js-block :statements (mapcar #'compile-to-statement body))) |
5aa10005 RD |
109 | |
110 | (defmethod expression-precedence ((body js-block)) | |
111 | (if (= (length (block-statements body)) 1) | |
112 | (expression-precedence (first (block-statements body))) | |
113 | (op-precedence 'comma))) | |
114 | ||
115 | ;;; function definition | |
46f794a4 | 116 | (define-script-special-form %js-lambda (args &rest body) |
5aa10005 RD |
117 | (make-instance 'js-lambda |
118 | :args (mapcar #'compile-to-symbol args) | |
119 | :body (make-instance 'js-block | |
120 | :indent " " | |
121 | :statements (mapcar #'compile-to-statement body)))) | |
122 | ||
46f794a4 | 123 | (define-script-special-form %js-defun (name args &rest body) |
5aa10005 RD |
124 | (make-instance 'js-defun |
125 | :name (compile-to-symbol name) | |
126 | :args (mapcar #'compile-to-symbol args) | |
127 | :body (make-instance 'js-block | |
128 | :indent " " | |
129 | :statements (mapcar #'compile-to-statement body)))) | |
130 | ||
131 | ;;; object creation | |
132 | (define-script-special-form create (&rest args) | |
133 | (make-instance 'js-object | |
134 | :slots (loop for (name val) on args by #'cddr | |
135 | collect (let ((name-expr (compile-to-expression name))) | |
136 | (assert (or (typep name-expr 'js-variable) | |
46f794a4 | 137 | (typep name-expr 'script-quote) |
5aa10005 RD |
138 | (typep name-expr 'string-literal) |
139 | (typep name-expr 'number-literal))) | |
140 | (list name-expr (compile-to-expression val)))))) | |
141 | ||
142 | ||
bbea4c83 | 143 | (define-script-special-form %js-slot-value (obj slot) |
a2196375 | 144 | (if (ps::expand-script-form slot) |
bbea4c83 RD |
145 | (make-instance 'js-slot-value |
146 | :object (compile-to-expression obj) | |
a2196375 VS |
147 | :slot (compile-script-form slot)) |
148 | (compile-to-expression obj))) | |
5aa10005 RD |
149 | |
150 | ;;; cond | |
151 | (define-script-special-form cond (&rest clauses) | |
152 | (make-instance 'js-cond | |
153 | :tests (mapcar (lambda (clause) (compile-to-expression (car clause))) | |
154 | clauses) | |
155 | :bodies (mapcar (lambda (clause) (compile-to-block (cons 'progn (cdr clause)) :indent " ")) | |
156 | clauses))) | |
157 | ||
158 | ;;; if | |
159 | (define-script-special-form if (test then &optional else) | |
160 | (make-instance 'js-if :test (compile-to-expression test) | |
161 | :then (compile-to-block then :indent " ") | |
162 | :else (when else | |
163 | (compile-to-block else :indent " ")))) | |
164 | ||
165 | (defmethod expression-precedence ((if js-if)) | |
166 | (op-precedence 'if)) | |
167 | ||
168 | ;;; switch | |
169 | (define-script-special-form switch (value &rest clauses) | |
170 | (let ((clauses (mapcar #'(lambda (clause) | |
171 | (let ((val (first clause)) | |
172 | (body (cdr clause))) | |
173 | (list (if (eql val 'default) | |
174 | 'default | |
175 | (compile-to-expression val)) | |
176 | (compile-to-block (cons 'progn body) :indent " ")))) | |
177 | clauses)) | |
178 | (check (compile-to-expression value))) | |
179 | (make-instance 'js-switch :value check | |
180 | :clauses clauses))) | |
181 | ||
182 | ||
183 | ;;; assignment | |
184 | (defun assignment-op (op) | |
185 | (case op | |
186 | (+ '+=) | |
187 | (~ '~=) | |
188 | (\& '\&=) | |
189 | (\| '\|=) | |
190 | (- '-=) | |
191 | (* '*=) | |
192 | (% '%=) | |
193 | (>> '>>=) | |
194 | (^ '^=) | |
195 | (<< '<<=) | |
196 | (>>> '>>>=) | |
197 | (/ '/=) | |
198 | (t nil))) | |
199 | ||
200 | (defun make-js-test (lhs rhs) | |
201 | (if (and (typep rhs 'op-form) | |
7590646c | 202 | (member lhs (op-args rhs) :test #'script-equal)) |
5aa10005 | 203 | (let ((args-without (remove lhs (op-args rhs) |
7590646c | 204 | :count 1 :test #'script-equal)) |
5aa10005 RD |
205 | (args-without-first (remove lhs (op-args rhs) |
206 | :count 1 :end 1 | |
7590646c | 207 | :test #'script-equal)) |
5aa10005 RD |
208 | (one (list (make-instance 'number-literal :value 1)))) |
209 | #+nil | |
210 | (format t "OPERATOR: ~S, ARGS-WITHOUT: ~S, ARGS-WITHOUT-FIRST ~S~%" | |
211 | (operator rhs) | |
212 | args-without | |
213 | args-without-first) | |
7590646c | 214 | (cond ((and (script-equal args-without one) |
5aa10005 RD |
215 | (eql (operator rhs) '+)) |
216 | (make-instance 'one-op :pre-p nil :op "++" | |
217 | :value lhs)) | |
7590646c | 218 | ((and (script-equal args-without-first one) |
5aa10005 RD |
219 | (eql (operator rhs) '-)) |
220 | (make-instance 'one-op :pre-p nil :op "--" | |
221 | :value lhs)) | |
222 | ((and (assignment-op (operator rhs)) | |
223 | (member (operator rhs) | |
224 | '(+ *)) | |
7590646c | 225 | (script-equal lhs (first (op-args rhs)))) |
5aa10005 RD |
226 | (make-instance 'op-form |
227 | :operator (assignment-op (operator rhs)) | |
228 | :args (list lhs (make-instance 'op-form | |
229 | :operator (operator rhs) | |
230 | :args args-without-first)))) | |
231 | ((and (assignment-op (operator rhs)) | |
7590646c | 232 | (script-equal (first (op-args rhs)) lhs)) |
5aa10005 RD |
233 | (make-instance 'op-form |
234 | :operator (assignment-op (operator rhs)) | |
235 | :args (list lhs (make-instance 'op-form | |
236 | :operator (operator rhs) | |
237 | :args (cdr (op-args rhs)))))) | |
238 | (t (make-instance 'js-setf :lhs lhs :rhsides (list rhs))))) | |
239 | (make-instance 'js-setf :lhs lhs :rhsides (list rhs)))) | |
240 | ||
72332f2a VS |
241 | (define-script-special-form setf1% (lhs rhs) |
242 | (make-js-test (compile-to-expression lhs) (compile-to-expression rhs))) | |
5aa10005 RD |
243 | |
244 | (defmethod expression-precedence ((setf js-setf)) | |
245 | (op-precedence '=)) | |
246 | ||
247 | ;;; defvar | |
248 | (define-script-special-form defvar (name &optional value) | |
249 | (make-instance 'js-defvar :names (list (compile-to-symbol name)) | |
250 | :value (when value (compile-to-expression value)))) | |
251 | ||
252 | ;;; iteration | |
253 | (defun make-for-vars (decls) | |
254 | (loop for decl in decls | |
255 | for var = (if (atom decl) decl (first decl)) | |
256 | for init = (if (atom decl) nil (second decl)) | |
257 | collect (make-instance 'js-defvar :names (list (compile-to-symbol var)) | |
258 | :value (compile-to-expression init)))) | |
259 | ||
260 | (defun make-for-steps (decls) | |
261 | (loop for decl in decls | |
262 | when (= (length decl) 3) | |
263 | collect (compile-to-expression (third decl)))) | |
264 | ||
265 | (define-script-special-form do (decls termination &rest body) | |
266 | (let ((vars (make-for-vars decls)) | |
267 | (steps (make-for-steps decls)) | |
268 | (check (compile-to-expression (list 'not (first termination)))) | |
269 | (body (compile-to-block (cons 'progn body) :indent " "))) | |
270 | (make-instance 'js-for | |
271 | :vars vars | |
272 | :steps steps | |
273 | :check check | |
274 | :body body))) | |
275 | ||
276 | (define-script-special-form doeach (decl &rest body) | |
277 | (make-instance 'for-each :name (compile-to-symbol (first decl)) | |
278 | :value (compile-to-expression (second decl)) | |
279 | :body (compile-to-block (cons 'progn body) :indent " "))) | |
280 | ||
281 | (define-script-special-form while (check &rest body) | |
282 | (make-instance 'js-while | |
283 | :check (compile-to-expression check) | |
284 | :body (compile-to-block (cons 'progn body) :indent " "))) | |
285 | ||
286 | ;;; with | |
287 | (define-script-special-form with (statement &rest body) | |
288 | (make-instance 'js-with | |
289 | :obj (compile-to-expression statement) | |
290 | :body (compile-to-block (cons 'progn body) :indent " "))) | |
291 | ||
292 | ||
293 | ;;; try-catch | |
294 | (define-script-special-form try (body &rest clauses) | |
295 | (let ((body (compile-to-block body :indent " ")) | |
296 | (catch (cdr (assoc :catch clauses))) | |
297 | (finally (cdr (assoc :finally clauses)))) | |
298 | (assert (not (cdar catch)) nil "Sorry, currently only simple catch forms are supported.") | |
299 | (make-instance 'js-try | |
300 | :body body | |
301 | :catch (when catch (list (compile-to-symbol (caar catch)) | |
302 | (compile-to-block (cons 'progn (cdr catch)) | |
303 | :indent " "))) | |
304 | :finally (when finally (compile-to-block (cons 'progn finally) | |
305 | :indent " "))))) | |
306 | ;;; regex | |
307 | (define-script-special-form regex (regex) | |
308 | (make-instance 'regex :value (string regex))) | |
309 | ||
310 | ;;; TODO instanceof | |
311 | (define-script-special-form instanceof (value type) | |
312 | (make-instance 'js-instanceof | |
313 | :value (compile-to-expression value) | |
314 | :type (compile-to-expression type))) | |
315 | ||
316 | ;;; single operations | |
317 | (defmacro define-parse-script-single-op (name &optional (superclass 'expression)) | |
318 | (let ((script-name (intern (concatenate 'string "JS-" (symbol-name name)) #.*package*))) | |
319 | `(define-script-special-form ,name (value) | |
320 | (make-instance ',script-name :value (compile-to-expression value))) | |
321 | )) | |
322 | ||
5aa10005 RD |
323 | (define-parse-script-single-op throw statement) |
324 | (define-parse-script-single-op delete) | |
325 | (define-parse-script-single-op void) | |
326 | (define-parse-script-single-op typeof) | |
327 | (define-parse-script-single-op new) | |
328 | ||
a2434734 VS |
329 | (define-script-special-form return (&optional value) |
330 | (make-instance 'js-return :value (compile-to-expression value))) | |
331 | ||
5aa10005 RD |
332 | ;;; conditional compilation |
333 | (define-script-special-form cc-if (test &rest body) | |
334 | (make-instance 'cc-if :test test | |
335 | :body (mapcar #'compile-script-form body))) | |
336 | ||
337 | ;;; standard macros | |
5aa10005 RD |
338 | (defscriptmacro when (test &rest body) |
339 | `(if ,test (progn ,@body))) | |
340 | ||
341 | (defscriptmacro unless (test &rest body) | |
342 | `(if (not ,test) (progn ,@body))) | |
343 | ||
344 | (defscriptmacro 1- (form) | |
345 | `(- ,form 1)) | |
346 | ||
347 | (defscriptmacro 1+ (form) | |
348 | `(+ ,form 1)) | |
349 | ||
5aa10005 RD |
350 | ;;; helper macros |
351 | (define-script-special-form js (&rest body) | |
352 | (make-instance 'string-literal | |
353 | :value (string-join (js-to-statement-strings | |
354 | (compile-script-form (cons 'progn body)) 0) " "))) | |
355 | ||
356 | (define-script-special-form script-inline (&rest body) | |
357 | (make-instance 'string-literal | |
358 | :value (concatenate | |
359 | 'string | |
360 | "javascript:" | |
361 | (string-join (js-to-statement-strings | |
362 | (compile-script-form (cons 'progn body)) 0) " ")))) | |
905f534e | 363 | (defscriptmacro parenscript::js-inline (&rest body) |
5aa10005 | 364 | `(script-inline ,@body)) |