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