Commit | Line | Data |
---|---|---|
4a987e2b | 1 | (in-package :parenscript) |
5aa10005 RD |
2 | |
3 | ;;;; The macrology of the basic Javascript-in-SEXPs language. Special forms and macros. | |
4 | ||
5 | ;;; literals | |
4a987e2b VS |
6 | (defmacro defpsliteral (name string) |
7 | `(define-ps-special-form ,name (expecting) (list 'js-literal ,string))) | |
8 | ||
9 | (defpsliteral this "this") | |
10 | (defpsliteral t "true") | |
11 | (defpsliteral true "true") | |
12 | (defpsliteral false "false") | |
13 | (defpsliteral f "false") | |
14 | (defpsliteral nil "null") | |
15 | (defpsliteral undefined "undefined") | |
16 | ||
17 | (defmacro defpskeyword (name string) | |
18 | `(define-ps-special-form ,name (expecting) (list 'js-keyword ,string))) | |
19 | ||
20 | (defpskeyword break "break") | |
21 | (defpskeyword continue "continue") | |
22 | ||
23 | (define-ps-special-form array (expecting &rest values) | |
24 | (cons 'array-literal (mapcar (lambda (form) (compile-parenscript-form form :expecting :expression)) | |
25 | values))) | |
26 | ||
27 | (define-ps-special-form aref (expecting array &rest coords) | |
28 | (list 'js-aref (compile-parenscript-form array :expecting :expression) | |
29 | (mapcar (lambda (form) | |
30 | (compile-parenscript-form form :expecting :expression)) | |
31 | coords))) | |
32 | ||
33 | (define-ps-special-form {} (expecting &rest arrows) | |
34 | (cons 'object-literal (loop for (key value) on arrows by #'cddr | |
35 | collect (cons key (compile-parenscript-form value :expecting :expression))))) | |
5aa10005 RD |
36 | |
37 | ;;; operators | |
4a987e2b VS |
38 | (define-ps-special-form incf (expecting x &optional (delta 1)) |
39 | (if (equal delta 1) | |
40 | (list 'unary-operator "++" (compile-parenscript-form x :expecting :expression) :prefix t) | |
41 | (list 'operator '+= (list (compile-parenscript-form x :expecting :expression) | |
42 | (compile-parenscript-form delta :expecting :expression))))) | |
43 | ||
44 | (define-ps-special-form decf (expecting x &optional (delta 1)) | |
45 | (if (equal delta 1) | |
46 | (list 'unary-operator "--" (compile-parenscript-form x :expecting :expression) :prefix t) | |
47 | (list 'operator '-= (list (compile-parenscript-form x :expecting :expression) | |
48 | (compile-parenscript-form delta :expecting :expression))))) | |
49 | ||
50 | (define-ps-special-form - (expecting first &rest rest) | |
5aa10005 | 51 | (if (null rest) |
4a987e2b VS |
52 | (list 'unary-operator "-" (compile-parenscript-form first :expecting :expression) :prefix t) |
53 | (list 'operator '- (mapcar (lambda (val) (compile-parenscript-form val :expecting :expression)) | |
54 | (cons first rest))))) | |
55 | ||
56 | (define-ps-special-form not (expecting x) | |
57 | (let ((form (compile-parenscript-form x :expecting :expression)) | |
58 | (not-op nil)) | |
59 | (if (and (eql (first form) 'operator) | |
60 | (= (length (third form)) 2) | |
61 | (setf not-op (case (second form) | |
62 | (== '!=) | |
63 | (< '>=) | |
64 | (> '<=) | |
65 | (<= '>) | |
66 | (>= '<) | |
67 | (!= '==) | |
68 | (=== '!==) | |
69 | (!== '===) | |
70 | (t nil)))) | |
71 | (list 'operator not-op (third form)) | |
72 | (list 'unary-operator "!" form :prefix t)))) | |
73 | ||
74 | (define-ps-special-form ~ (expecting x) | |
75 | (list 'unary-operator "~" (compile-parenscript-form x :expecting :expressin) :prefix t)) | |
76 | ||
839600e9 VS |
77 | (defun flatten-blocks (body) |
78 | (when body | |
4a987e2b | 79 | (if (and (listp (car body)) |
839600e9 VS |
80 | (eql 'js-block (caar body))) |
81 | (append (third (car body)) (flatten-blocks (cdr body))) | |
82 | (cons (car body) (flatten-blocks (cdr body)))))) | |
4a987e2b VS |
83 | |
84 | (define-ps-special-form progn (expecting &rest body) | |
b1017218 VS |
85 | (if (and (eql expecting :expression) (= 1 (length body))) |
86 | (compile-parenscript-form (car body) :expecting :expression) | |
87 | (list 'js-block | |
88 | (if (eql expecting :statement) t nil) | |
89 | (flatten-blocks (remove nil (mapcar (lambda (form) | |
90 | (compile-parenscript-form form :expecting :statement)) | |
91 | body)))))) | |
5aa10005 RD |
92 | |
93 | ;;; function definition | |
4a987e2b VS |
94 | (define-ps-special-form %js-lambda (expecting args &rest body) |
95 | (list 'js-lambda (mapcar (lambda (arg) | |
96 | (compile-parenscript-form arg :expecting :symbol)) | |
97 | args) | |
98 | (compile-parenscript-form `(progn ,@body)))) | |
99 | ||
100 | (define-ps-special-form %js-defun (expecting name args &rest body) | |
101 | (list 'js-defun (compile-parenscript-form name :expecting :symbol) | |
102 | (mapcar (lambda (val) (compile-parenscript-form val :expecting :symbol)) args) | |
103 | (compile-parenscript-form `(progn ,@body)))) | |
5aa10005 RD |
104 | |
105 | ;;; object creation | |
4a987e2b VS |
106 | (define-ps-special-form create (expecting &rest args) |
107 | (list 'js-object (loop for (name val) on args by #'cddr collecting | |
108 | (let ((name-expr (compile-parenscript-form name :expecting :expression))) | |
109 | (assert (or (stringp name-expr) | |
110 | (numberp name-expr) | |
111 | (and (listp name-expr) | |
112 | (or (eql 'js-variable (car name-expr)) | |
113 | (eql 'script-quote (car name-expr))))) | |
114 | () | |
115 | "Slot ~s is not one of js-variable, keyword, string or number." name-expr) | |
116 | (list name-expr (compile-parenscript-form val :expecting :expression)))))) | |
117 | ||
118 | (define-ps-special-form %js-slot-value (expecting obj slot) | |
119 | (if (ps::ps-macroexpand slot) | |
120 | (list 'js-slot-value (compile-parenscript-form obj :expecting :expression) (compile-parenscript-form slot)) | |
121 | (compile-parenscript-form obj :expecting :expression))) | |
122 | ||
123 | (define-ps-special-form cond (expecting &rest clauses) | |
0949f072 VS |
124 | (ecase expecting |
125 | (:statement (list 'js-cond-statement | |
126 | (mapcar (lambda (clause) | |
127 | (destructuring-bind (test &rest body) | |
128 | clause | |
129 | (list (compile-parenscript-form test :expecting :expression) | |
130 | (compile-parenscript-form `(progn ,@body))))) | |
131 | clauses))) | |
132 | (:expression (make-cond-clauses-into-nested-ifs clauses)))) | |
133 | ||
134 | (defun make-cond-clauses-into-nested-ifs (clauses) | |
135 | (if clauses | |
136 | (destructuring-bind (test &rest body) | |
137 | (car clauses) | |
138 | (if (eq t test) | |
139 | (compile-parenscript-form `(progn ,@body) :expecting :expression) | |
140 | (list 'js-expression-if (compile-parenscript-form test :expecting :expression) | |
141 | (compile-parenscript-form `(progn ,@body) :expecting :expression) | |
142 | (make-cond-clauses-into-nested-ifs (cdr clauses))))) | |
143 | (compile-parenscript-form nil :expecting :expression))) | |
4a987e2b VS |
144 | |
145 | (define-ps-special-form if (expecting test then &optional else) | |
146 | (ecase expecting | |
147 | (:statement (list 'js-statement-if (compile-parenscript-form test :expecting :expression) | |
148 | (compile-parenscript-form `(progn ,then)) | |
149 | (when else (compile-parenscript-form `(progn ,else))))) | |
150 | (:expression (list 'js-expression-if (compile-parenscript-form test :expecting :expression) | |
151 | (compile-parenscript-form then :expecting :expression) | |
5705b542 | 152 | (compile-parenscript-form else :expecting :expression))))) |
4a987e2b VS |
153 | |
154 | (define-ps-special-form switch (expecting test-expr &rest clauses) | |
155 | (let ((clauses (mapcar (lambda (clause) | |
156 | (let ((val (car clause)) | |
5aa10005 RD |
157 | (body (cdr clause))) |
158 | (list (if (eql val 'default) | |
159 | 'default | |
4a987e2b VS |
160 | (compile-parenscript-form val :expecting :expression)) |
161 | (compile-parenscript-form `(progn ,@body))))) | |
5aa10005 | 162 | clauses)) |
4a987e2b VS |
163 | (expr (compile-parenscript-form test-expr :expecting :expression))) |
164 | (list 'js-switch expr clauses))) | |
5aa10005 RD |
165 | |
166 | ;;; assignment | |
167 | (defun assignment-op (op) | |
168 | (case op | |
169 | (+ '+=) | |
170 | (~ '~=) | |
171 | (\& '\&=) | |
172 | (\| '\|=) | |
173 | (- '-=) | |
174 | (* '*=) | |
175 | (% '%=) | |
176 | (>> '>>=) | |
177 | (^ '^=) | |
178 | (<< '<<=) | |
179 | (>>> '>>>=) | |
180 | (/ '/=) | |
181 | (t nil))) | |
182 | ||
4a987e2b VS |
183 | (defun smart-setf (lhs rhs) |
184 | (if (and (listp rhs) | |
185 | (eql 'operator (car rhs)) | |
186 | (member lhs (third rhs) :test #'equalp)) | |
187 | (let ((args-without (remove lhs (third rhs) :count 1 :test #'equalp)) | |
188 | (args-without-first (remove lhs (third rhs) :count 1 :end 1 :test #'equalp))) | |
189 | (cond ((and (equal (car args-without) 1) (eql (second rhs) '+)) | |
190 | (list 'unary-operator "++" lhs :prefix nil)) | |
191 | ((and (equal (second args-without-first) 1) (eql (second rhs) '-)) | |
192 | (list 'unary-operator "--" lhs :prefix nil)) | |
193 | ((and (assignment-op (second rhs)) | |
194 | (member (second rhs) '(+ *)) | |
195 | (equalp lhs (first (third rhs)))) | |
196 | (list 'operator (assignment-op (second rhs)) | |
197 | (list lhs (list 'operator (second rhs) args-without-first)))) | |
198 | ((and (assignment-op (second rhs)) (equalp (first (third rhs)) lhs)) | |
199 | (list 'operator (assignment-op (second rhs)) | |
200 | (list lhs (list 'operator (second rhs) (cdr (third rhs)))))) | |
201 | (t (list 'js-assign lhs rhs)))) | |
202 | (list 'js-assign lhs rhs))) | |
203 | ||
204 | (define-ps-special-form setf1% (expecting lhs rhs) | |
205 | (smart-setf (compile-parenscript-form lhs :expecting :expression) (compile-parenscript-form rhs :expecting :expression))) | |
206 | ||
207 | (define-ps-special-form defvar (expecting name &rest value) | |
208 | (append (list 'js-defvar (compile-parenscript-form name :expecting :symbol)) | |
209 | (when value | |
210 | (assert (= (length value) 1) () "Wrong number of arguments to defvar: ~s" `(defvar ,name ,@value)) | |
211 | (list (compile-parenscript-form (car value) :expecting :expression))))) | |
5aa10005 RD |
212 | |
213 | ;;; iteration | |
214 | (defun make-for-vars (decls) | |
215 | (loop for decl in decls | |
216 | for var = (if (atom decl) decl (first decl)) | |
4a987e2b VS |
217 | for init-value = (if (atom decl) nil (second decl)) |
218 | collect (cons (compile-parenscript-form var :expecting :symbol) (compile-parenscript-form init-value)))) | |
5aa10005 RD |
219 | |
220 | (defun make-for-steps (decls) | |
221 | (loop for decl in decls | |
222 | when (= (length decl) 3) | |
4a987e2b | 223 | collect (compile-parenscript-form (third decl) :expecting :expression))) |
5aa10005 | 224 | |
4a987e2b | 225 | (define-ps-special-form do (expecting decls termination-test &rest body) |
5aa10005 RD |
226 | (let ((vars (make-for-vars decls)) |
227 | (steps (make-for-steps decls)) | |
4a987e2b VS |
228 | (test (compile-parenscript-form `(not ,(first termination-test)) :expecting :expression)) |
229 | (body (compile-parenscript-form `(progn ,@body)))) | |
230 | (list 'js-for vars steps test body))) | |
231 | ||
232 | (define-ps-special-form doeach (expecting decl &rest body) | |
233 | (list 'js-for-each | |
234 | (compile-parenscript-form (first decl) :expecting :symbol) | |
235 | (compile-parenscript-form (second decl) :expecting :expression) | |
236 | (compile-parenscript-form `(progn ,@body)))) | |
237 | ||
238 | (define-ps-special-form while (expecting test &rest body) | |
239 | (list 'js-while (compile-parenscript-form test :expecting :expression) | |
240 | (compile-parenscript-form `(progn ,@body)))) | |
241 | ||
242 | (define-ps-special-form with (expecting expression &rest body) | |
243 | (list 'js-with (compile-parenscript-form expression :expecting :expression) | |
244 | (compile-parenscript-form `(progn ,@body)))) | |
245 | ||
246 | (define-ps-special-form try (expecting form &rest clauses) | |
247 | (let ((catch (cdr (assoc :catch clauses))) | |
248 | (finally (cdr (assoc :finally clauses)))) | |
5aa10005 | 249 | (assert (not (cdar catch)) nil "Sorry, currently only simple catch forms are supported.") |
839600e9 VS |
250 | (assert (or catch finally) () |
251 | "Try form should have either a catch or a finally clause or both.") | |
4a987e2b VS |
252 | (list 'js-try (compile-parenscript-form `(progn ,form)) |
253 | :catch (when catch (list (compile-parenscript-form (caar catch) :expecting :symbol) | |
254 | (compile-parenscript-form `(progn ,@(cdr catch))))) | |
255 | :finally (when finally (compile-parenscript-form `(progn ,@finally)))))) | |
256 | ||
257 | (define-ps-special-form regex (expecting regex) | |
258 | (list 'js-regex (string regex))) | |
5aa10005 RD |
259 | |
260 | ;;; TODO instanceof | |
4a987e2b VS |
261 | (define-ps-special-form instanceof (expecting value type) |
262 | (list 'js-instanceof (compile-parenscript-form value :expecting :expression) | |
263 | (compile-parenscript-form type :expecting :expression))) | |
5aa10005 RD |
264 | |
265 | ;;; single operations | |
4a987e2b VS |
266 | (mapcar (lambda (op) (eval `(define-ps-special-form ,op (expecting value) |
267 | (list 'js-named-operator ',op (compile-parenscript-form value))))) | |
268 | '(throw delete void typeof new)) | |
5aa10005 | 269 | |
4a987e2b VS |
270 | (define-ps-special-form return (expecting &optional value) |
271 | (list 'js-return (compile-parenscript-form value :expecting :expression))) | |
a2434734 | 272 | |
5aa10005 | 273 | ;;; conditional compilation |
4a987e2b VS |
274 | (define-ps-special-form cc-if (expecting test &rest body) |
275 | (list 'cc-if test (mapcar #'compile-parenscript-form body))) | |
5aa10005 RD |
276 | |
277 | ;;; standard macros | |
4a987e2b | 278 | (defpsmacro when (test &rest body) |
5aa10005 RD |
279 | `(if ,test (progn ,@body))) |
280 | ||
4a987e2b | 281 | (defpsmacro unless (test &rest body) |
5aa10005 RD |
282 | `(if (not ,test) (progn ,@body))) |
283 | ||
4a987e2b | 284 | (defpsmacro 1- (form) |
5aa10005 RD |
285 | `(- ,form 1)) |
286 | ||
4a987e2b | 287 | (defpsmacro 1+ (form) |
5aa10005 | 288 | `(+ ,form 1)) |