Commit | Line | Data |
---|---|---|
5aa10005 RD |
1 | (in-package :parenscript) |
2 | ||
3 | ;;;; The macrology of the Parenscript language. Special forms and macros. | |
4 | ||
5 | ;;; parenscript gensyms | |
4a987e2b | 6 | (defvar *ps-gensym-counter* 0) |
5aa10005 | 7 | |
4a987e2b | 8 | (defun ps-gensym (&optional (prefix "_js")) |
0c542be0 | 9 | (make-symbol (format nil "~A~A" prefix (incf *ps-gensym-counter*)))) |
5aa10005 | 10 | |
4a987e2b VS |
11 | (defmacro with-ps-gensyms (symbols &body body) |
12 | "Evaluate BODY with SYMBOLS bound to unique ParenScript identifiers. | |
5aa10005 RD |
13 | |
14 | Each element of SYMBOLS is either a symbol or a list of (symbol | |
4a987e2b | 15 | gensym-prefix-string)." |
5aa10005 RD |
16 | `(let* ,(mapcar (lambda (symbol) |
17 | (destructuring-bind (symbol &optional prefix) | |
18 | (if (consp symbol) | |
19 | symbol | |
20 | (list symbol)) | |
21 | (if prefix | |
4a987e2b VS |
22 | `(,symbol (ps-gensym ,prefix)) |
23 | `(,symbol (ps-gensym))))) | |
5aa10005 RD |
24 | symbols) |
25 | ,@body)) | |
26 | ||
13b8268e VS |
27 | (defun constant-literal-form-p (form) |
28 | (or (numberp form) | |
29 | (stringp form) | |
30 | (and (listp form) | |
31 | (eql 'js-literal (car form))))) | |
32 | ||
4a987e2b | 33 | (defpsmacro defaultf (place value) |
bbea4c83 RD |
34 | `(setf ,place (or (and (=== undefined ,place) ,value) |
35 | ,place))) | |
46f794a4 | 36 | |
5aa10005 | 37 | ;;; array literals |
4a987e2b | 38 | (defpsmacro list (&rest values) |
5aa10005 RD |
39 | `(array ,@values)) |
40 | ||
4a987e2b | 41 | (defpsmacro make-array (&rest inits) |
5aa10005 RD |
42 | `(new (*array ,@inits))) |
43 | ||
bbea4c83 | 44 | ;;; slot access |
4a987e2b | 45 | (defpsmacro slot-value (obj &rest slots) |
bbea4c83 RD |
46 | (if (null (rest slots)) |
47 | `(%js-slot-value ,obj ,(first slots)) | |
48 | `(slot-value (slot-value ,obj ,(first slots)) ,@(rest slots)))) | |
49 | ||
4a987e2b | 50 | (defpsmacro with-slots (slots object &rest body) |
bbea4c83 RD |
51 | (flet ((slot-var (slot) (if (listp slot) (first slot) slot)) |
52 | (slot-symbol (slot) (if (listp slot) (second slot) slot))) | |
53 | `(symbol-macrolet ,(mapcar #'(lambda (slot) | |
43a1d5c3 | 54 | `(,(slot-var slot) (slot-value ,object ',(slot-symbol slot)))) |
bbea4c83 RD |
55 | slots) |
56 | ,@body))) | |
57 | ||
4a987e2b | 58 | (defpsmacro case (value &rest clauses) |
5aa10005 RD |
59 | (labels ((make-clause (val body more) |
60 | (cond ((listp val) | |
61 | (append (mapcar #'list (butlast val)) | |
62 | (make-clause (first (last val)) body more))) | |
63 | ((member val '(t otherwise)) | |
64 | (make-clause 'default body more)) | |
65 | (more `((,val ,@body break))) | |
66 | (t `((,val ,@body)))))) | |
4a987e2b VS |
67 | `(switch ,value ,@(mapcon (lambda (clause) |
68 | (make-clause (car (first clause)) | |
69 | (cdr (first clause)) | |
70 | (rest clause))) | |
5aa10005 RD |
71 | clauses)))) |
72 | ||
4a987e2b VS |
73 | (define-ps-special-form let (expecting bindings &rest body) |
74 | (let ((defvars (mapcar (lambda (binding) (if (atom binding) | |
75 | `(defvar ,binding) | |
76 | `(defvar ,@binding))) | |
77 | bindings))) | |
78 | (compile-parenscript-form `(progn ,@defvars ,@body)))) | |
5aa10005 RD |
79 | |
80 | ;;; iteration | |
4a987e2b | 81 | (defpsmacro dotimes (iter &rest body) |
5aa10005 RD |
82 | (let ((var (first iter)) |
83 | (times (second iter))) | |
84 | `(do ((,var 0 (1+ ,var))) | |
85 | ((>= ,var ,times)) | |
86 | ,@body))) | |
87 | ||
4a987e2b | 88 | (defpsmacro dolist (i-array &rest body) |
5aa10005 RD |
89 | (let ((var (first i-array)) |
90 | (array (second i-array)) | |
4a987e2b VS |
91 | (arrvar (ps-gensym "tmp-arr")) |
92 | (idx (ps-gensym "tmp-i"))) | |
5aa10005 RD |
93 | `(let ((,arrvar ,array)) |
94 | (do ((,idx 0 (1+ ,idx))) | |
4a987e2b | 95 | ((>= ,idx (slot-value ,arrvar 'length))) |
5aa10005 RD |
96 | (let ((,var (aref ,arrvar ,idx))) |
97 | ,@body))))) | |
98 | ||
99 | ;;; macros | |
100 | (defmacro with-temp-macro-environment ((var) &body body) | |
101 | `(let* ((,var (make-macro-env-dictionary)) | |
102 | (*script-macro-env* (cons ,var *script-macro-env*))) | |
103 | ,@body)) | |
104 | ||
4a987e2b | 105 | (define-ps-special-form macrolet (expecting macros &body body) |
5aa10005 RD |
106 | (with-temp-macro-environment (macro-env-dict) |
107 | (dolist (macro macros) | |
108 | (destructuring-bind (name arglist &body body) | |
109 | macro | |
110 | (setf (get-macro-spec name macro-env-dict) | |
921f2e02 | 111 | (cons nil (make-ps-macro-function arglist body))))) |
4a987e2b | 112 | (compile-parenscript-form `(progn ,@body)))) |
5aa10005 | 113 | |
4a987e2b | 114 | (define-ps-special-form symbol-macrolet (expecting symbol-macros &body body) |
5aa10005 RD |
115 | (with-temp-macro-environment (macro-env-dict) |
116 | (dolist (macro symbol-macros) | |
43a1d5c3 | 117 | (destructuring-bind (name expansion) |
5aa10005 RD |
118 | macro |
119 | (setf (get-macro-spec name macro-env-dict) | |
43a1d5c3 | 120 | (cons t (compile nil `(lambda () ',expansion)))))) |
4a987e2b | 121 | (compile-parenscript-form `(progn ,@body)))) |
5aa10005 | 122 | |
4a987e2b | 123 | (define-ps-special-form defmacro (expecting name args &body body) |
d9fc64c9 | 124 | (define-script-macro% name args body :symbol-macro-p nil) |
4a987e2b | 125 | nil) |
5aa10005 | 126 | |
4a987e2b | 127 | (define-ps-special-form define-symbol-macro (expecting name &body body) |
d9fc64c9 | 128 | (define-script-macro% name () body :symbol-macro-p t) |
4a987e2b | 129 | nil) |
46f794a4 | 130 | |
4a987e2b | 131 | (defpsmacro lisp (&body forms) |
5aa10005 RD |
132 | "Evaluates the given forms in Common Lisp at ParenScript |
133 | macro-expansion time. The value of the last form is treated as a | |
134 | ParenScript expression and is inserted into the generated Javascript | |
1b2da35c | 135 | \(use nil for no-op)." |
5aa10005 RD |
136 | (eval (cons 'progn forms))) |
137 | ||
4a987e2b | 138 | (defpsmacro rebind (variables &body body) |
5aa10005 | 139 | "Creates a new js lexical environment and copies the given |
34896dae AL |
140 | variable(s) there. Executes the body in the new environment. This |
141 | has the same effect as a new (let () ...) form in lisp but works on | |
142 | the js side for js closures." | |
5aa10005 RD |
143 | (unless (listp variables) |
144 | (setf variables (list variables))) | |
145 | `((lambda () | |
146 | (let ((new-context (new *object))) | |
147 | ,@(loop for variable in variables | |
34896dae AL |
148 | collect `(setf (slot-value new-context ,(symbol-to-js variable)) |
149 | ,variable)) | |
5aa10005 | 150 | (with new-context |
34896dae | 151 | ,@body))))) |
46f794a4 | 152 | |
46f794a4 RD |
153 | (eval-when (:compile-toplevel :load-toplevel :execute) |
154 | (defun parse-function-body (body) | |
155 | ;; (format t "parsing function body ~A~%" body) | |
156 | (let* ((documentation | |
157 | (when (stringp (first body)) | |
158 | (first body))) | |
159 | (body-forms (if documentation (rest body) body))) | |
160 | (values | |
161 | body-forms | |
162 | documentation))) | |
163 | ||
164 | (defun parse-key-spec (key-spec) | |
165 | "parses an &key parameter. Returns 4 values: | |
166 | var, init-form, keyword-name, supplied-p-var, init-form-supplied-p. | |
167 | ||
168 | Syntax of key spec: | |
169 | [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* | |
170 | " | |
171 | (let* ((var (cond ((symbolp key-spec) key-spec) | |
172 | ((and (listp key-spec) (symbolp (first key-spec))) (first key-spec)) | |
173 | ((and (listp key-spec) (listp (first key-spec))) (second key-spec)))) | |
174 | (keyword-name (if (and (listp key-spec) (listp (first key-spec))) | |
175 | (first (first key-spec)) | |
176 | (intern (string var) :keyword))) | |
177 | (init-form (if (listp key-spec) (second key-spec) nil)) | |
178 | (init-form-supplied-p (if (listp key-spec) t nil)) | |
179 | (supplied-p-var (if (listp key-spec) (third key-spec) nil))) | |
180 | (values var init-form keyword-name supplied-p-var init-form-supplied-p))) | |
181 | ||
182 | (defun parse-optional-spec (spec) | |
183 | "Parses an &optional parameter. Returns 3 values: var, init-form, supplied-p-var. | |
184 | [&optional {var | (var [init-form [supplied-p-parameter]])}*] " | |
185 | (let* ((var (cond ((symbolp spec) spec) | |
186 | ((and (listp spec) (first spec))))) | |
187 | (init-form (if (listp spec) (second spec))) | |
188 | (supplied-p-var (if (listp spec) (third spec)))) | |
189 | (values var init-form supplied-p-var))) | |
190 | ||
191 | (defun parse-aux-spec (spec) | |
192 | "Returns two values: variable and init-form" | |
193 | ;; [&aux {var | (var [init-form])}*]) | |
194 | (values (if (symbolp spec) spec (first spec)) | |
195 | (when (listp spec) (second spec)))) | |
196 | ||
197 | (defun parse-extended-function (lambda-list body &optional name) | |
198 | "Returns two values: the effective arguments and body for a function with | |
199 | the given lambda-list and body." | |
200 | ||
201 | ;; The lambda list is transformed as follows, since a javascript lambda list is just a | |
202 | ;; list of variable names, and you have access to the arguments variable inside the function: | |
203 | ;; * standard variables are the mapped directly into the js-lambda list | |
204 | ;; * optional variables' variable names are mapped directly into the lambda list, | |
205 | ;; and for each optional variable with name v and default value d, a form is produced | |
206 | ;; (defaultf v d) | |
d989d711 | 207 | ;; * when any keyword variables are in the lambda list, a single 'optional-args' variable is |
46f794a4 RD |
208 | ;; appended to the js-lambda list as the last argument. WITH-SLOTS is used for all |
209 | ;; the variables with inside the body of the function, | |
d989d711 | 210 | ;; a (with-slots ((var-name key-name)) optional-args ...) |
46f794a4 | 211 | (declare (ignore name)) |
bbea4c83 RD |
212 | (multiple-value-bind (requireds optionals rest? rest keys? keys allow? aux? aux |
213 | more? more-context more-count key-object) | |
46f794a4 | 214 | (parse-lambda-list lambda-list) |
bbea4c83 | 215 | (declare (ignore allow? aux? aux more? more-context more-count)) |
2e593e4c | 216 | (let* ((options-var (or key-object (ps-gensym))) |
46f794a4 RD |
217 | ;; optionals are of form (var default-value) |
218 | (effective-args | |
219 | (remove-if | |
220 | #'null | |
221 | (append requireds | |
222 | (mapcar #'parse-optional-spec optionals) | |
223 | (when keys (list options-var))))) | |
224 | ;; an alist of arg -> default val | |
225 | (initform-pairs | |
226 | (remove | |
227 | nil | |
228 | (append | |
229 | ;; optional arguments first | |
230 | (mapcar #'(lambda (opt-spec) | |
231 | (multiple-value-bind (var val) (parse-optional-spec opt-spec) | |
232 | (cons var val))) | |
233 | optionals) | |
234 | (if keys? (list (cons options-var '(create)))) | |
235 | (mapcar #'(lambda (key-spec) | |
236 | (multiple-value-bind (var val x y specified?) (parse-key-spec key-spec) | |
237 | (declare (ignore x y)) | |
238 | (when specified? (cons var val)))) | |
239 | keys)))) | |
240 | (body-paren-forms (parse-function-body body)) ;remove documentation | |
241 | ;; | |
242 | (initform-forms | |
243 | (mapcar #'(lambda (default-pair) | |
244 | `(defaultf ,(car default-pair) ,(cdr default-pair))) | |
245 | initform-pairs)) | |
246 | (rest-form | |
247 | (if rest? | |
44934751 VS |
248 | (with-ps-gensyms (i) |
249 | `(progn (defvar ,rest array) | |
250 | (dotimes (,i (- arguments.length ,(length effective-args))) | |
251 | (setf (aref ,rest ,i) (aref arguments (+ ,i ,(length effective-args))))))) | |
46f794a4 RD |
252 | `(progn))) |
253 | (effective-body (append initform-forms (list rest-form) body-paren-forms)) | |
254 | (effective-body | |
255 | (if keys? | |
256 | (list `(with-slots ,(mapcar #'(lambda (key-spec) | |
257 | (multiple-value-bind (var x key-name) | |
258 | (parse-key-spec key-spec) | |
259 | (declare (ignore x)) | |
260 | (list var key-name))) | |
261 | keys) | |
262 | ,options-var | |
263 | ,@effective-body)) | |
264 | effective-body))) | |
265 | (values effective-args effective-body))))) | |
266 | ||
4a987e2b | 267 | (defpsmacro defun (name lambda-list &body body) |
46f794a4 RD |
268 | "An extended defun macro that allows cool things like keyword arguments. |
269 | lambda-list::= | |
270 | (var* | |
271 | [&optional {var | (var [init-form [supplied-p-parameter]])}*] | |
272 | [&rest var] | |
273 | [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]] | |
274 | [&aux {var | (var [init-form])}*])" | |
dbb7017b VS |
275 | (if (symbolp name) |
276 | `(defun-normal ,name ,lambda-list ,@body) | |
277 | (progn (assert (and (= (length name) 2) (eql 'setf (car name))) () | |
278 | "(defun ~s ~s ...) needs to have a symbol or (setf symbol) for a name." name lambda-list) | |
279 | `(defun-setf ,name ,lambda-list ,@body)))) | |
280 | ||
4a987e2b | 281 | (defpsmacro defun-normal (name lambda-list &body body) |
46f794a4 RD |
282 | (multiple-value-bind (effective-args effective-body) |
283 | (parse-extended-function lambda-list body name) | |
284 | `(%js-defun ,name ,effective-args | |
285 | ,@effective-body))) | |
286 | ||
dbb7017b VS |
287 | (defvar *defun-setf-name-prefix* "__setf_") |
288 | ||
4a987e2b | 289 | (defpsmacro defun-setf (setf-name lambda-list &body body) |
dbb7017b VS |
290 | (let ((mangled-function-name (intern (concatenate 'string *defun-setf-name-prefix* (symbol-name (second setf-name))) |
291 | (symbol-package (second setf-name)))) | |
292 | (function-args (cdr (ordered-set-difference lambda-list lambda-list-keywords)))) | |
293 | `(progn (defsetf ,(second setf-name) ,(cdr lambda-list) (store-var) | |
294 | `(,',mangled-function-name ,store-var ,@(list ,@function-args))) | |
295 | (defun ,mangled-function-name ,lambda-list ,@body)))) | |
46f794a4 | 296 | |
4a987e2b | 297 | (defpsmacro lambda (lambda-list &body body) |
46f794a4 RD |
298 | "An extended defun macro that allows cool things like keyword arguments. |
299 | lambda-list::= | |
300 | (var* | |
301 | [&optional {var | (var [init-form [supplied-p-parameter]])}*] | |
302 | [&rest var] | |
303 | [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]] | |
304 | [&aux {var | (var [init-form])}*])" | |
305 | (multiple-value-bind (effective-args effective-body) | |
306 | (parse-extended-function lambda-list body) | |
307 | `(%js-lambda ,effective-args | |
72332f2a VS |
308 | ,@effective-body))) |
309 | ||
4a987e2b | 310 | (defpsmacro defsetf-long (access-fn lambda-list (store-var) form) |
06babcf5 | 311 | (setf (get-macro-spec access-fn *script-setf-expanders*) |
72332f2a | 312 | (compile nil |
cdf9ab0e | 313 | (let ((var-bindings (ordered-set-difference lambda-list lambda-list-keywords))) |
72332f2a VS |
314 | `(lambda (access-fn-args store-form) |
315 | (destructuring-bind ,lambda-list | |
316 | access-fn-args | |
4a987e2b VS |
317 | (let* ((,store-var (ps-gensym)) |
318 | (gensymed-names (loop repeat ,(length var-bindings) collecting (ps-gensym))) | |
72332f2a VS |
319 | (gensymed-arg-bindings (mapcar #'list gensymed-names (list ,@var-bindings)))) |
320 | (destructuring-bind ,var-bindings | |
321 | gensymed-names | |
cdf9ab0e | 322 | `(let (,@gensymed-arg-bindings |
03eedaa5 | 323 | (,,store-var ,store-form)) |
72332f2a VS |
324 | ,,form)))))))) |
325 | nil) | |
326 | ||
4a987e2b | 327 | (defpsmacro defsetf-short (access-fn update-fn &optional docstring) |
750651b0 | 328 | (declare (ignore docstring)) |
06babcf5 | 329 | (setf (get-macro-spec access-fn *script-setf-expanders*) |
750651b0 VS |
330 | (lambda (access-fn-args store-form) |
331 | `(,update-fn ,@access-fn-args ,store-form))) | |
332 | nil) | |
333 | ||
334 | (defpsmacro defsetf (access-fn &rest args) | |
335 | `(,(if (= (length args) 3) 'defsetf-long 'defsetf-short) ,access-fn ,@args)) | |
336 | ||
72332f2a VS |
337 | (defpsmacro setf (&rest args) |
338 | (flet ((process-setf-clause (place value-form) | |
06babcf5 VS |
339 | (if (and (listp place) (get-macro-spec (car place) *script-setf-expanders*)) |
340 | (funcall (get-macro-spec (car place) *script-setf-expanders*) (cdr place) value-form) | |
4a987e2b | 341 | (let ((exp-place (ps-macroexpand place))) |
06babcf5 VS |
342 | (if (and (listp exp-place) (get-macro-spec (car exp-place) *script-setf-expanders*)) |
343 | (funcall (get-macro-spec (car exp-place) *script-setf-expanders*) (cdr exp-place) value-form) | |
4a987e2b | 344 | `(setf1% ,exp-place ,value-form)))))) |
72332f2a VS |
345 | (assert (evenp (length args)) () |
346 | "~s does not have an even number of arguments." (cons 'setf args)) | |
347 | `(progn ,@(loop for (place value) on args by #'cddr collect (process-setf-clause place value))))) |