Fixed bug in keyword argument handling (patch thanks to Red Daly).
[clinton/parenscript.git] / src / special-forms.lisp
1 (in-package "PARENSCRIPT")
2
3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4 ;;; literals
5 (defmacro defpsliteral (name string)
6 `(progn
7 (add-ps-literal ',name)
8 (define-ps-special-form ,name ()
9 (list 'js:literal ,string))))
10
11 (defpsliteral this "this")
12 (defpsliteral t "true")
13 (defpsliteral true "true")
14 (defpsliteral false "false")
15 (defpsliteral f "false")
16 (defpsliteral nil "null")
17 (defpsliteral undefined "undefined")
18
19 (macrolet ((def-for-literal (name printer)
20 `(progn
21 (add-ps-literal ',name)
22 (define-ps-special-form ,name (&optional label)
23 (list ',printer label)))))
24 (def-for-literal break js:break)
25 (def-for-literal continue js:continue))
26
27 (defpsmacro quote (x)
28 (typecase x
29 (cons (cons 'array (mapcar (lambda (x) (when x `',x)) x)))
30 (null '(array))
31 (symbol (string-downcase x))
32 (number x)
33 (string x)))
34
35 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
36 ;;; unary operators
37 (macrolet ((def-unary-ops (&rest ops)
38 `(progn ,@(mapcar (lambda (op)
39 (let ((op (if (listp op) (car op) op))
40 (spacep (if (listp op) (second op) nil)))
41 `(define-ps-special-form ,op (x)
42 (list 'js:unary-operator ',op
43 (compile-parenscript-form x :expecting :expression)
44 :prefix t :space ,spacep))))
45 ops))))
46 (def-unary-ops ~ ! (new t) (delete t) (void t) (typeof t)))
47
48 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
49 ;;; statements
50 (define-ps-special-form return (&optional value)
51 `(js:return ,(compile-parenscript-form value :expecting :expression)))
52
53 (define-ps-special-form throw (value)
54 `(js:throw ,(compile-parenscript-form value :expecting :expression)))
55
56 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
57 ;;; arrays
58 (define-ps-special-form array (&rest values)
59 `(js:array ,@(mapcar (lambda (form) (compile-parenscript-form form :expecting :expression))
60 values)))
61
62 (define-ps-special-form aref (array &rest coords)
63 `(js:aref ,(compile-parenscript-form array :expecting :expression)
64 ,(mapcar (lambda (form)
65 (compile-parenscript-form form :expecting :expression))
66 coords)))
67
68 (defpsmacro list (&rest values)
69 `(array ,@values))
70
71 (defpsmacro make-array (&rest initial-values)
72 `(new (*array ,@initial-values)))
73
74 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
75 ;;; operators
76 (define-ps-special-form incf (x &optional (delta 1))
77 (if (eql delta 1)
78 `(js:unary-operator js:++ ,(compile-parenscript-form x :expecting :expression) :prefix t)
79 `(js:operator js:+= ,(compile-parenscript-form x :expecting :expression)
80 ,(compile-parenscript-form delta :expecting :expression))))
81
82 (define-ps-special-form decf (x &optional (delta 1))
83 (if (eql delta 1)
84 `(js:unary-operator js:-- ,(compile-parenscript-form x :expecting :expression) :prefix t)
85 `(js:operator js:-= ,(compile-parenscript-form x :expecting :expression)
86 ,(compile-parenscript-form delta :expecting :expression))))
87
88 (define-ps-special-form - (first &rest rest)
89 (if rest
90 `(js:operator js:- ,@(mapcar (lambda (val) (compile-parenscript-form val :expecting :expression))
91 (cons first rest)))
92 `(js:unary-operator js:- ,(compile-parenscript-form first :expecting :expression) :prefix t)))
93
94 (define-ps-special-form not (x)
95 (let ((form (compile-parenscript-form x :expecting :expression))
96 inverse-op)
97 (if (and (eq (car form) 'js:operator)
98 (= (length (cddr form)) 2)
99 (setf inverse-op (case (cadr form)
100 (== '!=)
101 (< '>=)
102 (> '<=)
103 (<= '>)
104 (>= '<)
105 (!= '==)
106 (=== '!==)
107 (!== '===))))
108 `(js:operator ,inverse-op ,@(cddr form))
109 `(js:unary-operator js:! ,form :prefix t))))
110
111 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
112 ;;; control structures
113 (defun flatten-blocks (body)
114 (when body
115 (if (and (listp (car body))
116 (eq 'js:block (caar body)))
117 (append (cdr (car body)) (flatten-blocks (cdr body)))
118 (cons (car body) (flatten-blocks (cdr body))))))
119
120 (defun constant-literal-form-p (form)
121 (or (numberp form)
122 (stringp form)
123 (and (listp form)
124 (eq 'js:literal (car form)))))
125
126 (define-ps-special-form progn (&rest body)
127 (if (and (eq expecting :expression) (= 1 (length body)))
128 (compile-parenscript-form (car body) :expecting :expression)
129 `(,(if (eq expecting :expression) 'js:|,| 'js:block)
130 ,@(let* ((block (flatten-blocks (remove nil (mapcar (lambda (form)
131 (compile-parenscript-form form :expecting expecting))
132 body)))))
133 (append (remove-if #'constant-literal-form-p (butlast block)) (last block))))))
134
135 (define-ps-special-form cond (&rest clauses)
136 (ecase expecting
137 (:statement `(js:if ,(compile-parenscript-form (caar clauses) :expecting :expression)
138 ,(compile-parenscript-form `(progn ,@(cdar clauses)))
139 ,@(loop for (test . body) in (cdr clauses) appending
140 (if (eq t test)
141 `(:else ,(compile-parenscript-form `(progn ,@body) :expecting :statement))
142 `(:else-if ,(compile-parenscript-form test :expecting :expression)
143 ,(compile-parenscript-form `(progn ,@body) :expecting :statement))))))
144 (:expression (make-cond-clauses-into-nested-ifs clauses))))
145
146 (defun make-cond-clauses-into-nested-ifs (clauses)
147 (if clauses
148 (destructuring-bind (test &rest body)
149 (car clauses)
150 (if (eq t test)
151 (compile-parenscript-form `(progn ,@body) :expecting :expression)
152 `(js:? ,(compile-parenscript-form test :expecting :expression)
153 ,(compile-parenscript-form `(progn ,@body) :expecting :expression)
154 ,(make-cond-clauses-into-nested-ifs (cdr clauses)))))
155 (compile-parenscript-form nil :expecting :expression))) ;; js:null
156
157 (define-ps-special-form if (test then &optional else)
158 (ecase expecting
159 (:statement `(js:if ,(compile-parenscript-form test :expecting :expression)
160 ,(compile-parenscript-form `(progn ,then))
161 ,@(when else `(:else ,(compile-parenscript-form `(progn ,else))))))
162 (:expression `(js:? ,(compile-parenscript-form test :expecting :expression)
163 ,(compile-parenscript-form then :expecting :expression)
164 ,(compile-parenscript-form else :expecting :expression)))))
165
166 (define-ps-special-form switch (test-expr &rest clauses)
167 `(js:switch ,(compile-parenscript-form test-expr :expecting :expression)
168 ,(loop for (val . body) in clauses collect
169 (cons (if (eq val 'default)
170 'default
171 (compile-parenscript-form val :expecting :expression))
172 (mapcar (lambda (x) (compile-parenscript-form x :expecting :statement))
173 body)))))
174
175 (defpsmacro case (value &rest clauses)
176 (labels ((make-clause (val body more)
177 (cond ((and (listp val) (not (eq (car val) 'quote)))
178 (append (mapcar #'list (butlast val))
179 (make-clause (first (last val)) body more)))
180 ((member val '(t otherwise))
181 (make-clause 'default body more))
182 (more `((,val ,@body break)))
183 (t `((,val ,@body))))))
184 `(switch ,value ,@(mapcon (lambda (clause)
185 (make-clause (car (first clause))
186 (cdr (first clause))
187 (rest clause)))
188 clauses))))
189
190 (defpsmacro when (test &rest body)
191 `(if ,test (progn ,@body)))
192
193 (defpsmacro unless (test &rest body)
194 `(if (not ,test) (progn ,@body)))
195
196 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
197 ;;; function definition
198 (defun compile-function-definition (args body)
199 (list (mapcar (lambda (arg) (compile-parenscript-form arg :expecting :symbol)) args)
200 (let ((*enclosing-lexical-block-declarations* ()))
201 ;; the first compilation will produce a list of variables we need to declare in the function body
202 (compile-parenscript-form `(progn ,@body) :expecting :statement)
203 ;; now declare and compile
204 (compile-parenscript-form `(progn
205 ,@(mapcar (lambda (var) `(var ,var)) *enclosing-lexical-block-declarations*)
206 ,@body)
207 :expecting :statement))))
208
209 (define-ps-special-form %js-lambda (args &rest body)
210 `(js:lambda ,@(compile-function-definition args body)))
211
212 (define-ps-special-form %js-defun (name args &rest body)
213 `(js:defun ,name ,@(compile-function-definition args body)))
214
215 (defun parse-function-body (body)
216 (let* ((docstring
217 (when (stringp (first body))
218 (first body)))
219 (body-forms (if docstring (rest body) body)))
220 (values body-forms docstring)))
221
222 (defun parse-key-spec (key-spec)
223 "parses an &key parameter. Returns 5 values:
224 var, init-form, keyword-name, supplied-p-var, init-form-supplied-p.
225
226 Syntax of key spec:
227 [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}*
228 "
229 (let* ((var (cond ((symbolp key-spec) key-spec)
230 ((and (listp key-spec) (symbolp (first key-spec))) (first key-spec))
231 ((and (listp key-spec) (listp (first key-spec))) (second (first key-spec)))))
232 (keyword-name (if (and (listp key-spec) (listp (first key-spec)))
233 (first (first key-spec))
234 (intern (string var) :keyword)))
235 (init-form (if (listp key-spec) (second key-spec) nil))
236 (init-form-supplied-p (if (listp key-spec) t nil))
237 (supplied-p-var (if (listp key-spec) (third key-spec) nil)))
238 (values var init-form keyword-name supplied-p-var init-form-supplied-p)))
239
240 (defun parse-optional-spec (spec)
241 "Parses an &optional parameter. Returns 3 values: var, init-form, supplied-p-var.
242 [&optional {var | (var [init-form [supplied-p-parameter]])}*] "
243 (let* ((var (cond ((symbolp spec) spec)
244 ((and (listp spec) (first spec)))))
245 (init-form (if (listp spec) (second spec)))
246 (supplied-p-var (if (listp spec) (third spec))))
247 (values var init-form supplied-p-var)))
248
249 (defun parse-aux-spec (spec)
250 "Returns two values: variable and init-form"
251 ;; [&aux {var | (var [init-form])}*])
252 (values (if (symbolp spec) spec (first spec))
253 (when (listp spec) (second spec))))
254
255 (defpsmacro defaultf (place value)
256 `(when (=== ,place undefined)
257 (setf ,place ,value)))
258
259 (defun parse-extended-function (lambda-list body &optional name)
260 "Returns two values: the effective arguments and body for a function with
261 the given lambda-list and body."
262
263 ;; The lambda list is transformed as follows, since a javascript lambda list is just a
264 ;; list of variable names, and you have access to the arguments variable inside the function:
265 ;; * standard variables are the mapped directly into the js-lambda list
266 ;; * optional variables' variable names are mapped directly into the lambda list,
267 ;; and for each optional variable with name v and default value d, a form is produced
268 ;; (defaultf v d)
269 ;; * keyword variables are not included in the js-lambda list, but instead are
270 ;; obtained from the magic js ARGUMENTS pseudo-array. Code assigning values to
271 ;; keyword vars is prepended to the body of the function.
272 (declare (ignore name))
273 (multiple-value-bind (requireds optionals rest? rest keys? keys allow? aux? aux
274 more? more-context more-count key-object)
275 (parse-lambda-list lambda-list)
276 (declare (ignore allow? aux? aux more? more-context more-count key-object))
277 (let* (;; optionals are of form (var default-value)
278 (effective-args
279 (remove-if
280 #'null
281 (append requireds
282 (mapcar #'parse-optional-spec optionals))))
283 (opt-forms
284 (mapcar #'(lambda (opt-spec)
285 (multiple-value-bind (var val) (parse-optional-spec opt-spec)
286 `(defaultf ,var ,val)))
287 optionals))
288 (key-forms
289 (when keys?
290 (if (< *js-target-version* 1.6)
291 (with-ps-gensyms (n)
292 (let ((decls nil) (assigns nil) (defaults nil))
293 (mapc (lambda (k)
294 (multiple-value-bind (var init-form keyword-str)
295 (parse-key-spec k)
296 (push `(var ,var) decls)
297 (push `(,keyword-str (setf ,var (aref arguments (1+ ,n)))) assigns)
298 (push (list 'defaultf var init-form) defaults)))
299 (reverse keys))
300 `(,@decls
301 (loop :for ,n :from ,(length requireds)
302 :below (length arguments) :by 2 :do
303 (case (aref arguments ,n) ,@assigns))
304 ,@defaults)))
305 (mapcar (lambda (k)
306 (multiple-value-bind (var init-form keyword-str)
307 (parse-key-spec k)
308 (with-ps-gensyms (x)
309 `(let ((,x ((@ *Array prototype index-of call) arguments ,keyword-str ,(length requireds))))
310 (var ,var (if (= -1 ,x) ,init-form (aref arguments (1+ ,x))))))))
311 keys))))
312 (rest-form
313 (if rest?
314 (with-ps-gensyms (i)
315 `(progn (var ,rest (array))
316 (dotimes (,i (- (slot-value arguments 'length) ,(length effective-args)))
317 (setf (aref ,rest ,i) (aref arguments (+ ,i ,(length effective-args)))))))
318 `(progn)))
319 (body-paren-forms (parse-function-body body)) ; remove documentation
320 (effective-body (append opt-forms key-forms (list rest-form) body-paren-forms)))
321 (values effective-args effective-body))))
322
323 (defpsmacro defun (name lambda-list &body body)
324 "An extended defun macro that allows cool things like keyword arguments.
325 lambda-list::=
326 (var*
327 [&optional {var | (var [init-form [supplied-p-parameter]])}*]
328 [&rest var]
329 [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
330 [&aux {var | (var [init-form])}*])"
331 (if (symbolp name)
332 `(defun-function ,name ,lambda-list ,@body)
333 (progn (assert (and (listp name) (= (length name) 2) (eq 'setf (car name))) ()
334 "(defun ~s ~s ...) needs to have a symbol or (setf symbol) for a name." name lambda-list)
335 `(defun-setf ,name ,lambda-list ,@body))))
336
337 (defpsmacro defun-function (name lambda-list &body body)
338 (multiple-value-bind (effective-args effective-body)
339 (parse-extended-function lambda-list body name)
340 `(%js-defun ,name ,effective-args
341 ,@effective-body)))
342
343 (defvar *defun-setf-name-prefix* "__setf_")
344
345 (defpsmacro defun-setf (setf-name lambda-list &body body)
346 (let ((mangled-function-name (intern (concatenate 'string *defun-setf-name-prefix* (symbol-name (second setf-name)))
347 (symbol-package (second setf-name))))
348 (function-args (cdr (ordered-set-difference lambda-list lambda-list-keywords))))
349 `(progn (defsetf ,(second setf-name) ,(cdr lambda-list) (store-var)
350 `(,',mangled-function-name ,store-var ,@(list ,@function-args)))
351 (defun ,mangled-function-name ,lambda-list ,@body))))
352
353 (defpsmacro lambda (lambda-list &body body)
354 "An extended defun macro that allows cool things like keyword arguments.
355 lambda-list::=
356 (var*
357 [&optional {var | (var [init-form [supplied-p-parameter]])}*]
358 [&rest var]
359 [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
360 [&aux {var | (var [init-form])}*])"
361 (multiple-value-bind (effective-args effective-body)
362 (parse-extended-function lambda-list body)
363 `(%js-lambda ,effective-args
364 ,@effective-body)))
365
366 (defpsmacro flet (fn-defs &rest body)
367 (flet ((process-fn-def (def)
368 `(var ,(car def) (lambda ,@(cdr def)))))
369 `(progn ,@(mapcar #'process-fn-def fn-defs) ,@body)))
370
371 (defpsmacro labels (fn-defs &rest body)
372 (flet ((process-fn-def (def)
373 `(var ,(car def) (defun ,(car def) ,@(cdr def)))))
374 `(progn ,@(mapcar #'process-fn-def fn-defs) ,@body)))
375
376 (defpsmacro defsetf-long (access-fn lambda-list (store-var) form)
377 (setf (get-macro-spec access-fn *ps-setf-expanders*)
378 (compile nil
379 (let ((var-bindings (ordered-set-difference lambda-list lambda-list-keywords)))
380 `(lambda (access-fn-args store-form)
381 (destructuring-bind ,lambda-list
382 access-fn-args
383 (let* ((,store-var (ps-gensym))
384 (gensymed-names (loop repeat ,(length var-bindings) collecting (ps-gensym)))
385 (gensymed-arg-bindings (mapcar #'list gensymed-names (list ,@var-bindings))))
386 (destructuring-bind ,var-bindings
387 gensymed-names
388 `(let* (,@gensymed-arg-bindings
389 (,,store-var ,store-form))
390 ,,form))))))))
391 nil)
392
393 (defpsmacro defsetf-short (access-fn update-fn &optional docstring)
394 (declare (ignore docstring))
395 (setf (get-macro-spec access-fn *ps-setf-expanders*)
396 (lambda (access-fn-args store-form)
397 `(,update-fn ,@access-fn-args ,store-form)))
398 nil)
399
400 (defpsmacro defsetf (access-fn &rest args)
401 `(,(if (= (length args) 3) 'defsetf-long 'defsetf-short) ,access-fn ,@args))
402
403 (defpsmacro funcall (&rest arg-form)
404 arg-form)
405
406 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
407 ;;; macros
408 (defmacro with-temp-macro-environment ((var) &body body)
409 `(let* ((,var (make-macro-env-dictionary))
410 (*ps-macro-env* (cons ,var *ps-macro-env*)))
411 ,@body))
412
413 (define-ps-special-form macrolet (macros &body body)
414 (with-temp-macro-environment (macro-env-dict)
415 (dolist (macro macros)
416 (destructuring-bind (name arglist &body body)
417 macro
418 (setf (get-macro-spec name macro-env-dict)
419 (cons nil (eval (make-ps-macro-function arglist body))))))
420 (compile-parenscript-form `(progn ,@body))))
421
422 (define-ps-special-form symbol-macrolet (symbol-macros &body body)
423 (with-temp-macro-environment (macro-env-dict)
424 (dolist (macro symbol-macros)
425 (destructuring-bind (name expansion)
426 macro
427 (setf (get-macro-spec name macro-env-dict)
428 (cons t (lambda (x) (declare (ignore x)) expansion)))))
429 (compile-parenscript-form `(progn ,@body))))
430
431 (define-ps-special-form defmacro (name args &body body) ;; should this be a macro?
432 (eval `(defpsmacro ,name ,args ,@body))
433 nil)
434
435 (define-ps-special-form define-symbol-macro (name expansion) ;; should this be a macro?
436 (eval `(define-ps-symbol-macro ,name ,expansion))
437 nil)
438
439 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
440 ;;; objects
441 (add-ps-literal '{})
442 (define-ps-symbol-macro {} (create))
443
444 (define-ps-special-form create (&rest arrows)
445 `(js:object ,@(loop for (key-expr val-expr) on arrows by #'cddr collecting
446 (let ((key (compile-parenscript-form key-expr :expecting :expression)))
447 (when (keywordp key)
448 (setf key `(js:variable ,key)))
449 (assert (or (stringp key)
450 (numberp key)
451 (and (listp key)
452 (or (eq 'js:variable (car key))
453 (eq 'quote (car key)))))
454 ()
455 "Slot key ~s is not one of js-variable, keyword, string or number." key)
456 (cons key (compile-parenscript-form val-expr :expecting :expression))))))
457
458 (define-ps-special-form %js-slot-value (obj slot)
459 `(js:slot-value ,(compile-parenscript-form obj :expecting :expression)
460 ,(if (and (listp slot) (eq 'quote (car slot)))
461 (second slot) ;; assume we're quoting a symbol
462 (compile-parenscript-form slot))))
463
464 (define-ps-special-form instanceof (value type)
465 `(js:instanceof ,(compile-parenscript-form value :expecting :expression)
466 ,(compile-parenscript-form type :expecting :expression)))
467
468 (defpsmacro slot-value (obj &rest slots)
469 (if (null (rest slots))
470 `(%js-slot-value ,obj ,(first slots))
471 `(slot-value (slot-value ,obj ,(first slots)) ,@(rest slots))))
472
473 (defpsmacro with-slots (slots object &rest body)
474 (flet ((slot-var (slot) (if (listp slot) (first slot) slot))
475 (slot-symbol (slot) (if (listp slot) (second slot) slot)))
476 `(symbol-macrolet ,(mapcar #'(lambda (slot)
477 `(,(slot-var slot) (slot-value ,object ',(slot-symbol slot))))
478 slots)
479 ,@body)))
480
481 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
482 ;;; assignment and binding
483 (defun assignment-op (op)
484 (case op
485 (+ '+=)
486 (~ '~=)
487 (\& '\&=)
488 (\| '\|=)
489 (- '-=)
490 (* '*=)
491 (% '%=)
492 (>> '>>=)
493 (^ '^=)
494 (<< '<<=)
495 (>>> '>>>=)
496 (/ '/=)
497 (t nil)))
498
499 (define-ps-special-form setf1% (lhs rhs)
500 (let ((lhs (compile-parenscript-form lhs :expecting :expression))
501 (rhs (compile-parenscript-form rhs :expecting :expression)))
502 (if (and (listp rhs)
503 (eq 'js:operator (car rhs))
504 (member (cadr rhs) '(+ *))
505 (equalp lhs (caddr rhs)))
506 `(js:operator ,(assignment-op (cadr rhs)) ,lhs (js:operator ,(cadr rhs) ,@(cdddr rhs)))
507 `(js:= ,lhs ,rhs))))
508
509 (defpsmacro setf (&rest args)
510 (flet ((process-setf-clause (place value-form)
511 (if (and (listp place) (get-macro-spec (car place) *ps-setf-expanders*))
512 (funcall (get-macro-spec (car place) *ps-setf-expanders*) (cdr place) value-form)
513 (let ((exp-place (ps-macroexpand place)))
514 (if (and (listp exp-place) (get-macro-spec (car exp-place) *ps-setf-expanders*))
515 (funcall (get-macro-spec (car exp-place) *ps-setf-expanders*) (cdr exp-place) value-form)
516 `(setf1% ,exp-place ,value-form))))))
517 (assert (evenp (length args)) ()
518 "~s does not have an even number of arguments." (cons 'setf args))
519 `(progn ,@(loop for (place value) on args by #'cddr collect (process-setf-clause place value)))))
520
521 (defpsmacro psetf (&rest args)
522 (let ((vars (loop for x in args by #'cddr collect x))
523 (vals (loop for x in (cdr args) by #'cddr collect x)))
524 (let ((gensyms (mapcar (lambda (x) (declare (ignore x)) (ps-gensym)) vars)))
525 `(simple-let* ,(mapcar #'list gensyms vals)
526 (setf ,@(mapcan #'list vars gensyms))))))
527
528 (defun check-setq-args (args)
529 (let ((vars (loop for x in args by #'cddr collect x)))
530 (let ((non-var (find-if (complement #'symbolp) vars)))
531 (when non-var
532 (error 'type-error :datum non-var :expected-type 'symbol)))))
533
534 (defpsmacro setq (&rest args)
535 (check-setq-args args)
536 `(setf ,@args))
537
538 (defpsmacro psetq (&rest args)
539 (check-setq-args args)
540 `(psetf ,@args))
541
542 (define-ps-special-form var (name &optional (value (values) value-provided?) documentation)
543 (declare (ignore documentation))
544 `(js:var ,name ,@(when value-provided?
545 (list (compile-parenscript-form value :expecting :expression)))))
546
547 (defpsmacro defvar (name &optional (value (values) value-provided?) documentation)
548 "Note: this must be used as a top-level form, otherwise the result will be undefined behavior."
549 (pushnew name *ps-special-variables*)
550 `(var ,name ,@(when value-provided? (list value))))
551
552 (defun make-let-vars (bindings)
553 (mapcar (lambda (x) (if (listp x) (car x) x)) bindings))
554
555 (defun make-let-vals (bindings)
556 (mapcar (lambda (x) (if (or (atom x) (endp (cdr x))) nil (second x))) bindings))
557
558 (defpsmacro lexical-let* (bindings &body body)
559 `((lambda ()
560 (let* ,bindings
561 ,@body))))
562
563 (defpsmacro lexical-let (bindings &body body)
564 `((lambda ,(make-let-vars bindings)
565 ,@body)
566 ,@(make-let-vals bindings)))
567
568 (defpsmacro simple-let* (bindings &body body)
569 (if bindings
570 (let ((var (if (listp (car bindings)) (caar bindings) (car bindings))))
571 `(,(if (member var *ps-special-variables*) 'let1-dynamic 'let1) ,(car bindings)
572 (simple-let* ,(cdr bindings) ,@body)))
573 `(progn ,@body)))
574
575 (defpsmacro simple-let (bindings &body body)
576 (let ((vars (mapcar (lambda (x) (if (atom x) x (first x))) bindings))
577 (vals (mapcar (lambda (x) (if (or (atom x) (endp (cdr x))) nil (second x))) bindings)))
578 (let ((gensyms (mapcar (lambda (x) (ps-gensym (format nil "_js_~a" x))) vars)))
579 `(simple-let* ,(mapcar #'list gensyms vals)
580 (simple-let* ,(mapcar #'list vars gensyms)
581 ,@(mapcar (lambda (x) `(delete ,x)) gensyms)
582 ,@body)))))
583
584 (defpsmacro let* (bindings &body body)
585 `(simple-let* ,bindings ,@body))
586
587 (defpsmacro let (bindings &body body)
588 `(,(if (= 1 (length bindings)) 'simple-let* 'simple-let) ,bindings ,@body))
589
590 (define-ps-special-form let1 (binding &rest body)
591 (ecase expecting
592 (:statement
593 (compile-parenscript-form `(progn ,(if (atom binding) `(var ,binding) `(var ,@binding)) ,@body) :expecting :statement))
594 (:expression
595 (let ((var (if (atom binding) binding (car binding)))
596 (variable-assignment (when (listp binding) (cons 'setf binding))))
597 (push var *enclosing-lexical-block-declarations*)
598 (compile-parenscript-form `(progn ,variable-assignment ,@body) :expecting :expression)))))
599
600 (defpsmacro let1-dynamic ((var value) &rest body)
601 (with-ps-gensyms (temp-stack-var)
602 `(progn (var ,temp-stack-var)
603 (try (progn (setf ,temp-stack-var ,var)
604 (setf ,var ,value)
605 ,@body)
606 (:finally
607 (setf ,var ,temp-stack-var)
608 (delete ,temp-stack-var))))))
609
610 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
611 ;;; iteration
612 (defun make-for-vars/inits (init-forms)
613 (mapcar (lambda (x)
614 (cons (compile-parenscript-form (if (atom x) x (first x)) :expecting :symbol)
615 (compile-parenscript-form (if (atom x) nil (second x)) :expecting :expression)))
616 init-forms))
617
618 (define-ps-special-form labeled-for (label init-forms cond-forms step-forms &rest body)
619 `(js:for ,label
620 ,(make-for-vars/inits init-forms)
621 ,(mapcar (lambda (x) (compile-parenscript-form x :expecting :expression)) cond-forms)
622 ,(mapcar (lambda (x) (compile-parenscript-form x :expecting :expression)) step-forms)
623 ,(compile-parenscript-form `(progn ,@body))))
624
625 (defpsmacro for (init-forms cond-forms step-forms &body body)
626 `(labeled-for nil ,init-forms ,cond-forms ,step-forms ,@body))
627
628 (defun do-make-let-bindings (decls)
629 (mapcar (lambda (x)
630 (if (atom x) x
631 (if (endp (cdr x)) (list (car x))
632 (subseq x 0 2))))
633 decls))
634
635 (defun do-make-init-vars (decls)
636 (mapcar (lambda (x) (if (atom x) x (first x))) decls))
637
638 (defun do-make-init-vals (decls)
639 (mapcar (lambda (x) (if (or (atom x) (endp (cdr x))) nil (second x))) decls))
640
641 (defun do-make-for-vars/init (decls)
642 (mapcar (lambda (x)
643 (if (atom x) x
644 (if (endp (cdr x)) x
645 (subseq x 0 2))))
646 decls))
647
648 (defun do-make-for-steps (decls)
649 (mapcar (lambda (x)
650 `(setf ,(first x) ,(third x)))
651 (remove-if (lambda (x) (or (atom x) (< (length x) 3))) decls)))
652
653 (defun do-make-iter-psteps (decls)
654 `(psetq
655 ,@(mapcan (lambda (x) (list (first x) (third x)))
656 (remove-if (lambda (x) (or (atom x) (< (length x) 3))) decls))))
657
658 (defpsmacro do* (decls (termination &optional (result nil result?)) &body body)
659 (if result?
660 `((lambda ()
661 (for ,(do-make-for-vars/init decls) ((not ,termination)) ,(do-make-for-steps decls)
662 ,@body)
663 (return ,result)))
664 `(progn
665 (for ,(do-make-for-vars/init decls) ((not ,termination)) ,(do-make-for-steps decls)
666 ,@body))))
667
668 (defpsmacro do (decls (termination &optional (result nil result?)) &body body)
669 (if result?
670 `((lambda ,(do-make-init-vars decls)
671 (for () ((not ,termination)) ()
672 ,@body
673 ,(do-make-iter-psteps decls))
674 (return ,result))
675 ,@(do-make-init-vals decls))
676 `(let ,(do-make-let-bindings decls)
677 (for () ((not ,termination)) ()
678 ,@body
679 ,(do-make-iter-psteps decls)))))
680
681 (define-ps-special-form for-in ((var object) &rest body)
682 `(js:for-in ,(compile-parenscript-form `(var ,var) :expecting :expression)
683 ,(compile-parenscript-form object :expecting :expression)
684 ,(compile-parenscript-form `(progn ,@body))))
685
686 (define-ps-special-form while (test &rest body)
687 `(js:while ,(compile-parenscript-form test :expecting :expression)
688 ,(compile-parenscript-form `(progn ,@body))))
689
690 (defpsmacro dotimes ((var count &optional (result nil result?)) &rest body)
691 `(do* ((,var 0 (1+ ,var)))
692 ((>= ,var ,count) ,@(when result? (list result)))
693 ,@body))
694
695 (defpsmacro dolist ((var array &optional (result nil result?)) &body body)
696 (let ((idx (ps-gensym "_js_idx"))
697 (arrvar (ps-gensym "_js_arrvar")))
698 `(do* (,var
699 (,arrvar ,array)
700 (,idx 0 (1+ ,idx)))
701 ((>= ,idx (slot-value ,arrvar 'length))
702 ,@(when result? (list result)))
703 (setq ,var (aref ,arrvar ,idx))
704 ,@body)))
705
706 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
707 ;;; misc
708 (define-ps-special-form with (expression &rest body)
709 `(js:with ,(compile-parenscript-form expression :expecting :expression)
710 ,(compile-parenscript-form `(progn ,@body))))
711
712 (define-ps-special-form try (form &rest clauses)
713 (let ((catch (cdr (assoc :catch clauses)))
714 (finally (cdr (assoc :finally clauses))))
715 (assert (not (cdar catch)) nil "Sorry, currently only simple catch forms are supported.")
716 (assert (or catch finally) ()
717 "Try form should have either a catch or a finally clause or both.")
718 `(js:try ,(compile-parenscript-form `(progn ,form))
719 :catch ,(when catch (list (compile-parenscript-form (caar catch) :expecting :symbol)
720 (compile-parenscript-form `(progn ,@(cdr catch)))))
721 :finally ,(when finally (compile-parenscript-form `(progn ,@finally))))))
722
723 (define-ps-special-form cc-if (test &rest body)
724 `(js:cc-if ,test ,@(mapcar #'compile-parenscript-form body)))
725
726 (define-ps-special-form regex (regex)
727 `(js:regex ,(string regex)))
728
729 (define-ps-special-form lisp (lisp-form)
730 ;; (ps (foo (lisp bar))) is in effect equivalent to (ps* `(foo ,bar))
731 ;; when called from inside of ps*, lisp-form has access only to the dynamic environment (like for eval)
732 `(js:escape (ps1* ,lisp-form)))