1 (in-package :parenscript
)
3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
5 (defmacro defpsliteral
(name string
)
7 (add-ps-literal ',name
)
8 (define-ps-special-form ,name
(expecting)
9 (declare (ignore expecting
))
10 (list 'js-literal
,string
))))
12 (defpsliteral this
"this")
13 (defpsliteral t
"true")
14 (defpsliteral true
"true")
15 (defpsliteral false
"false")
16 (defpsliteral f
"false")
17 (defpsliteral nil
"null")
18 (defpsliteral undefined
"undefined")
20 (macrolet ((def-for-literal (name printer
)
22 (add-ps-literal ',name
)
23 (define-ps-special-form ,name
(expecting &optional label
)
24 (declare (ignore expecting
))
25 (list ',printer label
)))))
26 (def-for-literal break js-break
)
27 (def-for-literal continue js-continue
))
29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
31 (macrolet ((def-unary-ops (&rest ops
)
32 `(progn ,@(mapcar (lambda (op)
33 (let ((op (if (listp op
) (car op
) op
))
34 (spacep (if (listp op
) (second op
) nil
)))
35 `(define-ps-special-form ,op
(expecting x
)
36 (declare (ignore expecting
))
37 (list 'unary-operator
',op
38 (compile-parenscript-form x
:expecting
:expression
)
39 :prefix t
:space
,spacep
))))
41 (def-unary-ops ~
! (new t
) (delete t
) (void t
) (typeof t
)))
43 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
45 (define-ps-special-form return
(expecting &optional value
)
46 (declare (ignore expecting
))
47 (list 'js-return
(compile-parenscript-form value
:expecting
:expression
)))
49 (define-ps-special-form throw
(expecting value
)
50 (declare (ignore expecting
))
51 (list 'js-throw
(compile-parenscript-form value
:expecting
:expression
)))
53 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
55 (define-ps-special-form array
(expecting &rest values
)
56 (declare (ignore expecting
))
57 (cons 'array-literal
(mapcar (lambda (form) (compile-parenscript-form form
:expecting
:expression
))
60 (define-ps-special-form aref
(expecting array
&rest coords
)
61 (declare (ignore expecting
))
62 (list 'js-aref
(compile-parenscript-form array
:expecting
:expression
)
63 (mapcar (lambda (form)
64 (compile-parenscript-form form
:expecting
:expression
))
67 (defpsmacro list
(&rest values
)
70 (defpsmacro make-array
(&rest initial-values
)
71 `(new (*array
,@initial-values
)))
73 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
75 (define-ps-special-form incf
(expecting x
&optional
(delta 1))
76 (declare (ignore expecting
))
78 (list 'unary-operator
'++ (compile-parenscript-form x
:expecting
:expression
) :prefix t
)
79 (list 'operator
'+= (list (compile-parenscript-form x
:expecting
:expression
)
80 (compile-parenscript-form delta
:expecting
:expression
)))))
82 (define-ps-special-form decf
(expecting x
&optional
(delta 1))
83 (declare (ignore expecting
))
85 (list 'unary-operator
'--
(compile-parenscript-form x
:expecting
:expression
) :prefix t
)
86 (list 'operator
'-
= (list (compile-parenscript-form x
:expecting
:expression
)
87 (compile-parenscript-form delta
:expecting
:expression
)))))
89 (define-ps-special-form -
(expecting first
&rest rest
)
90 (declare (ignore expecting
))
92 (list 'unary-operator
'-
(compile-parenscript-form first
:expecting
:expression
) :prefix t
)
93 (list 'operator
'-
(mapcar (lambda (val) (compile-parenscript-form val
:expecting
:expression
))
96 (define-ps-special-form not
(expecting x
)
97 (declare (ignore expecting
))
98 (let ((form (compile-parenscript-form x
:expecting
:expression
))
100 (if (and (eql (first form
) 'operator
)
101 (= (length (third form
)) 2)
102 (setf not-op
(case (second form
)
112 (list 'operator not-op
(third form
))
113 (list 'unary-operator
'! form
:prefix t
))))
115 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
116 ;;; control structures
117 (defun flatten-blocks (body)
119 (if (and (listp (car body
))
120 (eql 'js-block
(caar body
)))
121 (append (third (car body
)) (flatten-blocks (cdr body
)))
122 (cons (car body
) (flatten-blocks (cdr body
))))))
124 (defun constant-literal-form-p (form)
128 (eql 'js-literal
(car form
)))))
130 (define-ps-special-form progn
(expecting &rest body
)
131 (if (and (eql expecting
:expression
) (= 1 (length body
)))
132 (compile-parenscript-form (car body
) :expecting
:expression
)
135 (let* ((block (mapcar (lambda (form)
136 (compile-parenscript-form form
:expecting expecting
))
138 (clean-block (remove nil block
))
139 (flat-block (flatten-blocks clean-block
))
140 (reachable-block (append (remove-if #'constant-literal-form-p
(butlast flat-block
))
144 (define-ps-special-form cond
(expecting &rest clauses
)
146 (:statement
(list 'js-cond-statement
147 (mapcar (lambda (clause)
148 (destructuring-bind (test &rest body
)
150 (list (compile-parenscript-form test
:expecting
:expression
)
151 (compile-parenscript-form `(progn ,@body
) :expecting
:statement
))))
153 (:expression
(make-cond-clauses-into-nested-ifs clauses
))))
155 (defun make-cond-clauses-into-nested-ifs (clauses)
157 (destructuring-bind (test &rest body
)
160 (compile-parenscript-form `(progn ,@body
) :expecting
:expression
)
161 (list 'js-expression-if
(compile-parenscript-form test
:expecting
:expression
)
162 (compile-parenscript-form `(progn ,@body
) :expecting
:expression
)
163 (make-cond-clauses-into-nested-ifs (cdr clauses
)))))
164 (compile-parenscript-form nil
:expecting
:expression
)))
166 (define-ps-special-form if
(expecting test then
&optional else
)
168 (:statement
(list 'js-statement-if
(compile-parenscript-form test
:expecting
:expression
)
169 (compile-parenscript-form `(progn ,then
))
170 (when else
(compile-parenscript-form `(progn ,else
)))))
171 (:expression
(list 'js-expression-if
(compile-parenscript-form test
:expecting
:expression
)
172 (compile-parenscript-form then
:expecting
:expression
)
173 (compile-parenscript-form else
:expecting
:expression
)))))
175 (define-ps-special-form switch
(expecting test-expr
&rest clauses
)
176 (declare (ignore expecting
))
177 (let ((clauses (mapcar (lambda (clause)
178 (let ((val (car clause
))
180 (cons (if (and (symbolp val
)
181 (eq (ensure-ps-symbol val
) 'default
))
183 (compile-parenscript-form val
:expecting
:expression
))
184 (mapcar (lambda (statement) (compile-parenscript-form statement
:expecting
:statement
))
187 (expr (compile-parenscript-form test-expr
:expecting
:expression
)))
188 (list 'js-switch expr clauses
)))
190 (defpsmacro case
(value &rest clauses
)
191 (labels ((make-clause (val body more
)
192 (cond ((and (listp val
) (not (eq (car val
) 'quote
)))
193 (append (mapcar #'list
(butlast val
))
194 (make-clause (first (last val
)) body more
)))
195 ((member val
'(t otherwise
))
196 (make-clause 'default body more
))
197 (more `((,val
,@body break
)))
198 (t `((,val
,@body
))))))
199 `(switch ,value
,@(mapcon (lambda (clause)
200 (make-clause (car (first clause
))
205 (defpsmacro when
(test &rest body
)
206 `(if ,test
(progn ,@body
)))
208 (defpsmacro unless
(test &rest body
)
209 `(if (not ,test
) (progn ,@body
)))
211 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
212 ;;; function definition
213 (defun compile-function-definition (args body
)
214 (list (mapcar (lambda (arg) (compile-parenscript-form arg
:expecting
:symbol
)) args
)
215 (let ((*enclosing-lexical-block-declarations
* ()))
216 ;; the first compilation will produce a list of variables we need to declare in the function body
217 (compile-parenscript-form `(progn ,@body
) :expecting
:statement
)
218 ;; now declare and compile
219 (compile-parenscript-form `(progn ,@(loop for var in
*enclosing-lexical-block-declarations
* collect
`(var ,var
))
220 ,@body
) :expecting
:statement
))))
222 (define-ps-special-form %js-lambda
(expecting args
&rest body
)
223 (declare (ignore expecting
))
224 (cons 'js-lambda
(compile-function-definition args body
)))
226 (define-ps-special-form %js-defun
(expecting name args
&rest body
)
227 (declare (ignore expecting
))
228 (append (list 'js-defun
name) (compile-function-definition args body
)))
230 (defun parse-function-body (body)
232 (when (stringp (first body
))
234 (body-forms (if docstring
(rest body
) body
)))
235 (values body-forms docstring
)))
237 (defun parse-key-spec (key-spec)
238 "parses an &key parameter. Returns 4 values:
239 var, init-form, keyword-name, supplied-p-var, init-form-supplied-p.
242 [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}*
244 (let* ((var (cond ((symbolp key-spec
) key-spec
)
245 ((and (listp key-spec
) (symbolp (first key-spec
))) (first key-spec
))
246 ((and (listp key-spec
) (listp (first key-spec
))) (second key-spec
))))
247 (keyword-name (if (and (listp key-spec
) (listp (first key-spec
)))
248 (first (first key-spec
))
249 (intern (string var
) :keyword
)))
250 (init-form (if (listp key-spec
) (second key-spec
) nil
))
251 (init-form-supplied-p (if (listp key-spec
) t nil
))
252 (supplied-p-var (if (listp key-spec
) (third key-spec
) nil
)))
253 (values var init-form keyword-name supplied-p-var init-form-supplied-p
)))
255 (defun parse-optional-spec (spec)
256 "Parses an &optional parameter. Returns 3 values: var, init-form, supplied-p-var.
257 [&optional {var | (var [init-form [supplied-p-parameter]])}*] "
258 (let* ((var (cond ((symbolp spec
) spec
)
259 ((and (listp spec
) (first spec
)))))
260 (init-form (if (listp spec
) (second spec
)))
261 (supplied-p-var (if (listp spec
) (third spec
))))
262 (values var init-form supplied-p-var
)))
264 (defun parse-aux-spec (spec)
265 "Returns two values: variable and init-form"
266 ;; [&aux {var | (var [init-form])}*])
267 (values (if (symbolp spec
) spec
(first spec
))
268 (when (listp spec
) (second spec
))))
270 (defpsmacro defaultf
(place value
)
271 `(when (=== ,place undefined
)
272 (setf ,place
,value
)))
274 (defun parse-extended-function (lambda-list body
&optional name
)
275 "Returns two values: the effective arguments and body for a function with
276 the given lambda-list and body."
278 ;; The lambda list is transformed as follows, since a javascript lambda list is just a
279 ;; list of variable names, and you have access to the arguments variable inside the function:
280 ;; * standard variables are the mapped directly into the js-lambda list
281 ;; * optional variables' variable names are mapped directly into the lambda list,
282 ;; and for each optional variable with name v and default value d, a form is produced
284 ;; * when any keyword variables are in the lambda list, a single 'optional-args' variable is
285 ;; appended to the js-lambda list as the last argument. WITH-SLOTS is used for all
286 ;; the variables with inside the body of the function,
287 ;; a (with-slots ((var-name key-name)) optional-args ...)
288 (declare (ignore name
))
289 (multiple-value-bind (requireds optionals rest? rest keys? keys allow? aux? aux
290 more? more-context more-count key-object
)
291 (parse-lambda-list lambda-list
)
292 (declare (ignore allow? aux? aux more? more-context more-count
))
293 (let* ((options-var (or key-object
(ps-gensym)))
294 ;; optionals are of form (var default-value)
299 (mapcar #'parse-optional-spec optionals
)
300 (when keys
(list options-var
)))))
301 ;; an alist of arg -> default val
306 ;; optional arguments first
307 (mapcar #'(lambda (opt-spec)
308 (multiple-value-bind (var val
) (parse-optional-spec opt-spec
)
311 (if keys?
(list (cons options-var
'(create))))
312 (mapcar #'(lambda (key-spec)
313 (multiple-value-bind (var val x y specified?
) (parse-key-spec key-spec
)
314 (declare (ignore x y
))
315 (when specified?
(cons var val
))))
317 (body-paren-forms (parse-function-body body
)) ; remove documentation
319 (mapcar #'(lambda (default-pair)
320 `(defaultf ,(car default-pair
) ,(cdr default-pair
)))
325 `(progn (var ,rest
(array))
326 (dotimes (,i
(- arguments.length
,(length effective-args
)))
327 (setf (aref ,rest
,i
) (aref arguments
(+ ,i
,(length effective-args
)))))))
329 (effective-body (append initform-forms
(list rest-form
) body-paren-forms
))
332 (list `(with-slots ,(mapcar #'(lambda (key-spec)
333 (multiple-value-bind (var x key-name
)
334 (parse-key-spec key-spec
)
336 (list var key-name
)))
341 (values effective-args effective-body
))))
343 (defpsmacro defun
(name lambda-list
&body body
)
344 "An extended defun macro that allows cool things like keyword arguments.
347 [&optional {var | (var [init-form [supplied-p-parameter]])}*]
349 [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
350 [&aux {var | (var [init-form])}*])"
352 `(defun-function ,name
,lambda-list
,@body
)
353 (progn (assert (and (= (length name
) 2) (eq 'setf
(ensure-ps-symbol (car name
)))) ()
354 "(defun ~s ~s ...) needs to have a symbol or (setf symbol) for a name." name lambda-list
)
355 `(defun-setf ,name
,lambda-list
,@body
))))
357 (defpsmacro defun-function
(name lambda-list
&body body
)
358 (multiple-value-bind (effective-args effective-body
)
359 (parse-extended-function lambda-list body name
)
360 `(%js-defun
,name
,effective-args
363 (defvar *defun-setf-name-prefix
* "__setf_")
365 (defpsmacro defun-setf
(setf-name lambda-list
&body body
)
366 (let ((mangled-function-name (intern (concatenate 'string
*defun-setf-name-prefix
* (symbol-name (second setf-name
)))
367 (symbol-package (second setf-name
))))
368 (function-args (cdr (ordered-set-difference lambda-list lambda-list-keywords
))))
369 `(progn (defsetf ,(second setf-name
) ,(cdr lambda-list
) (store-var)
370 `(,',mangled-function-name
,store-var
,@(list ,@function-args
)))
371 (defun ,mangled-function-name
,lambda-list
,@body
))))
373 (defpsmacro lambda
(lambda-list &body body
)
374 "An extended defun macro that allows cool things like keyword arguments.
377 [&optional {var | (var [init-form [supplied-p-parameter]])}*]
379 [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
380 [&aux {var | (var [init-form])}*])"
381 (multiple-value-bind (effective-args effective-body
)
382 (parse-extended-function lambda-list body
)
383 `(%js-lambda
,effective-args
386 (defpsmacro flet
(fn-defs &rest body
)
387 (flet ((process-fn-def (def)
388 `(var ,(car def
) (lambda ,@(cdr def
)))))
389 `(progn ,@(mapcar #'process-fn-def fn-defs
) ,@body
)))
391 (defpsmacro labels
(fn-defs &rest body
)
392 (flet ((process-fn-def (def)
393 `(var ,(car def
) (defun ,(car def
) ,@(cdr def
)))))
394 `(progn ,@(mapcar #'process-fn-def fn-defs
) ,@body
)))
396 (defpsmacro defsetf-long
(access-fn lambda-list
(store-var) form
)
397 (setf (get-macro-spec access-fn
*ps-setf-expanders
*)
399 (let ((var-bindings (ordered-set-difference lambda-list lambda-list-keywords
)))
400 `(lambda (access-fn-args store-form
)
401 (destructuring-bind ,lambda-list
403 (let* ((,store-var
(ps-gensym))
404 (gensymed-names (loop repeat
,(length var-bindings
) collecting
(ps-gensym)))
405 (gensymed-arg-bindings (mapcar #'list gensymed-names
(list ,@var-bindings
))))
406 (destructuring-bind ,var-bindings
408 `(let* (,@gensymed-arg-bindings
409 (,,store-var
,store-form
))
413 (defpsmacro defsetf-short
(access-fn update-fn
&optional docstring
)
414 (declare (ignore docstring
))
415 (setf (get-macro-spec access-fn
*ps-setf-expanders
*)
416 (lambda (access-fn-args store-form
)
417 `(,update-fn
,@access-fn-args
,store-form
)))
420 (defpsmacro defsetf
(access-fn &rest args
)
421 `(,(if (= (length args
) 3) 'defsetf-long
'defsetf-short
) ,access-fn
,@args
))
423 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
425 (defmacro with-temp-macro-environment
((var) &body body
)
426 `(let* ((,var
(make-macro-env-dictionary))
427 (*ps-macro-env
* (cons ,var
*ps-macro-env
*)))
430 (define-ps-special-form macrolet
(expecting macros
&body body
)
431 (declare (ignore expecting
))
432 (with-temp-macro-environment (macro-env-dict)
433 (dolist (macro macros
)
434 (destructuring-bind (name arglist
&body body
)
436 (setf (get-macro-spec name macro-env-dict
)
437 (cons nil
(eval (make-ps-macro-function arglist body
))))))
438 (compile-parenscript-form `(progn ,@body
))))
440 (define-ps-special-form symbol-macrolet
(expecting symbol-macros
&body body
)
441 (declare (ignore expecting
))
442 (with-temp-macro-environment (macro-env-dict)
443 (dolist (macro symbol-macros
)
444 (destructuring-bind (name expansion
)
446 (setf (get-macro-spec name macro-env-dict
)
447 (cons t
(lambda () expansion
)))))
448 (compile-parenscript-form `(progn ,@body
))))
450 (define-ps-special-form defmacro
(expecting name args
&body body
)
451 (declare (ignore expecting
))
452 (eval `(defpsmacro ,name
,args
,@body
))
455 (define-ps-special-form define-symbol-macro
(expecting name expansion
)
456 (declare (ignore expecting
))
457 (eval `(define-ps-symbol-macro ,name
,expansion
))
460 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
463 (define-ps-symbol-macro {} (create))
465 (define-ps-special-form create
(expecting &rest arrows
)
466 (declare (ignore expecting
))
467 (list 'js-object
(loop for
(key-expr val-expr
) on arrows by
#'cddr collecting
468 (let ((key (compile-parenscript-form key-expr
:expecting
:expression
)))
470 (setf key
(list 'js-variable key
)))
471 (assert (or (stringp key
)
474 (or (eq 'js-variable
(car key
))
475 (eq 'ps-quote
(car key
)))))
477 "Slot key ~s is not one of js-variable, keyword, string or number." key
)
478 (cons key
(compile-parenscript-form val-expr
:expecting
:expression
))))))
480 (define-ps-special-form %js-slot-value
(expecting obj slot
)
481 (declare (ignore expecting
))
482 (if (ps::ps-macroexpand slot
)
483 (list 'js-slot-value
(compile-parenscript-form obj
:expecting
:expression
) (compile-parenscript-form slot
))
484 (compile-parenscript-form obj
:expecting
:expression
)))
486 (define-ps-special-form instanceof
(expecting value type
)
487 (declare (ignore expecting
))
488 (list 'js-instanceof
(compile-parenscript-form value
:expecting
:expression
)
489 (compile-parenscript-form type
:expecting
:expression
)))
491 (defpsmacro slot-value
(obj &rest slots
)
492 (if (null (rest slots
))
493 `(%js-slot-value
,obj
,(first slots
))
494 `(slot-value (slot-value ,obj
,(first slots
)) ,@(rest slots
))))
496 (defpsmacro with-slots
(slots object
&rest body
)
497 (flet ((slot-var (slot) (if (listp slot
) (first slot
) slot
))
498 (slot-symbol (slot) (if (listp slot
) (second slot
) slot
)))
499 `(symbol-macrolet ,(mapcar #'(lambda (slot)
500 `(,(slot-var slot
) (slot-value ,object
',(slot-symbol slot
))))
504 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
505 ;;; assignment and binding
506 (defun assignment-op (op)
522 (defun smart-setf (lhs rhs
)
524 (eql 'operator
(car rhs
))
525 (member lhs
(third rhs
) :test
#'equalp
))
526 (let ((args-without-first (remove lhs
(third rhs
) :count
1 :end
1 :test
#'equalp
)))
527 (cond ((and (assignment-op (second rhs
))
528 (member (second rhs
) '(+ *))
529 (equalp lhs
(first (third rhs
))))
530 (list 'operator
(assignment-op (second rhs
))
531 (list lhs
(list 'operator
(second rhs
) args-without-first
))))
532 (t (list 'js-assign lhs rhs
))))
533 (list 'js-assign lhs rhs
)))
535 (define-ps-special-form setf1%
(expecting lhs rhs
)
536 (declare (ignore expecting
))
537 (smart-setf (compile-parenscript-form lhs
:expecting
:expression
) (compile-parenscript-form rhs
:expecting
:expression
)))
539 (defpsmacro setf
(&rest args
)
540 (flet ((process-setf-clause (place value-form
)
541 (if (and (listp place
) (get-macro-spec (car place
) *ps-setf-expanders
*))
542 (funcall (get-macro-spec (car place
) *ps-setf-expanders
*) (cdr place
) value-form
)
543 (let ((exp-place (ps-macroexpand place
)))
544 (if (and (listp exp-place
) (get-macro-spec (car exp-place
) *ps-setf-expanders
*))
545 (funcall (get-macro-spec (car exp-place
) *ps-setf-expanders
*) (cdr exp-place
) value-form
)
546 `(setf1%
,exp-place
,value-form
))))))
547 (assert (evenp (length args
)) ()
548 "~s does not have an even number of arguments." (cons 'setf args
))
549 `(progn ,@(loop for
(place value
) on args by
#'cddr collect
(process-setf-clause place value
)))))
551 (defpsmacro psetf
(&rest args
)
552 (let ((vars (loop for x in args by
#'cddr collect x
))
553 (vals (loop for x in
(cdr args
) by
#'cddr collect x
)))
554 (let ((gensyms (mapcar (lambda (x) (declare (ignore x
)) (ps-gensym)) vars
)))
555 `(simple-let* ,(mapcar #'list gensyms vals
)
556 (setf ,@(mapcan #'list vars gensyms
))))))
558 (defun check-setq-args (args)
559 (let ((vars (loop for x in args by
#'cddr collect x
)))
560 (let ((non-var (find-if (complement #'symbolp
) vars
)))
562 (error 'type-error
:datum non-var
:expected-type
'symbol
)))))
564 (defpsmacro setq
(&rest args
)
565 (check-setq-args args
)
568 (defpsmacro psetq
(&rest args
)
569 (check-setq-args args
)
572 (define-ps-special-form var
(expecting name
&rest value
)
573 (declare (ignore expecting
))
574 (append (list 'js-var name
)
576 (assert (= (length value
) 1) () "Wrong number of arguments to var: ~s" `(var ,name
,@value
))
577 (list (compile-parenscript-form (car value
) :expecting
:expression
)))))
579 (defpsmacro defvar
(name &rest value
)
580 "Note: this must be used as a top-level form, otherwise the result will be undefined behavior."
581 (pushnew name
*ps-special-variables
*)
582 (assert (or (null value
) (= (length value
) 1)) () "Wrong number of arguments to defvar: ~s" `(defvar ,name
,@value
))
583 `(var ,name
,@value
))
585 (defun make-let-vars (bindings)
586 (mapcar (lambda (x) (if (listp x
) (car x
) x
)) bindings
))
588 (defun make-let-vals (bindings)
589 (mapcar (lambda (x) (if (or (atom x
) (endp (cdr x
))) nil
(second x
))) bindings
))
591 (defpsmacro lexical-let
* (bindings &body body
)
596 (defpsmacro lexical-let
(bindings &body body
)
597 `((lambda ,(make-let-vars bindings
)
599 ,@(make-let-vals bindings
)))
601 (defpsmacro simple-let
* (bindings &body body
)
603 (let ((var (if (listp (car bindings
)) (caar bindings
) (car bindings
))))
604 `(,(if (member var
*ps-special-variables
*) 'let1-dynamic
'let1
) ,(car bindings
)
605 (simple-let* ,(cdr bindings
) ,@body
)))
608 (defpsmacro simple-let
(bindings &body body
)
609 (let ((vars (mapcar (lambda (x) (if (atom x
) x
(first x
))) bindings
))
610 (vals (mapcar (lambda (x) (if (or (atom x
) (endp (cdr x
))) nil
(second x
))) bindings
)))
611 (let ((gensyms (mapcar (lambda (x) (ps-gensym (format nil
"_js_~a" x
))) vars
)))
612 `(simple-let* ,(mapcar #'list gensyms vals
)
613 (simple-let* ,(mapcar #'list vars gensyms
)
614 ,@(mapcar (lambda (x) `(delete ,x
)) gensyms
)
617 (defpsmacro let
* (bindings &body body
)
618 `(simple-let* ,bindings
,@body
))
620 (defpsmacro let
(bindings &body body
)
621 `(,(if (= 1 (length bindings
)) 'simple-let
* 'simple-let
) ,bindings
,@body
))
623 (define-ps-special-form let1
(expecting binding
&rest body
)
626 (compile-parenscript-form `(progn ,(if (atom binding
) `(var ,binding
) `(var ,@binding
)) ,@body
) :expecting
:statement
))
628 (let ((var (if (atom binding
) binding
(car binding
)))
629 (variable-assignment (when (listp binding
) (cons 'setf binding
))))
630 (push var
*enclosing-lexical-block-declarations
*)
631 (compile-parenscript-form `(progn ,variable-assignment
,@body
) :expecting
:expression
)))))
633 (defpsmacro let1-dynamic
((var value
) &rest body
)
634 (with-ps-gensyms (temp-stack-var)
635 `(progn (var ,temp-stack-var
)
636 (try (progn (setf ,temp-stack-var
,var
)
640 (setf ,var
,temp-stack-var
)
641 (delete ,temp-stack-var
))))))
643 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
645 (defun make-for-vars/inits
(init-forms)
647 (cons (compile-parenscript-form (if (atom x
) x
(first x
)) :expecting
:symbol
)
648 (compile-parenscript-form (if (atom x
) nil
(second x
)) :expecting
:expression
)))
651 (define-ps-special-form labeled-for
(expecting label init-forms cond-forms step-forms
&rest body
)
652 (declare (ignore expecting
))
653 (let ((vars (make-for-vars/inits init-forms
))
654 (steps (mapcar (lambda (x) (compile-parenscript-form x
:expecting
:expression
)) step-forms
))
655 (tests (mapcar (lambda (x) (compile-parenscript-form x
:expecting
:expression
)) cond-forms
))
656 (body (compile-parenscript-form `(progn ,@body
))))
657 (list 'js-for label vars tests steps body
)))
659 (defpsmacro for
(init-forms cond-forms step-forms
&body body
)
660 `(labeled-for nil
,init-forms
,cond-forms
,step-forms
,@body
))
662 (defun do-make-let-bindings (decls)
665 (if (endp (cdr x
)) (list (car x
))
669 (defun do-make-init-vars (decls)
670 (mapcar (lambda (x) (if (atom x
) x
(first x
))) decls
))
672 (defun do-make-init-vals (decls)
673 (mapcar (lambda (x) (if (or (atom x
) (endp (cdr x
))) nil
(second x
))) decls
))
675 (defun do-make-for-vars/init
(decls)
682 (defun do-make-for-steps (decls)
684 `(setf ,(first x
) ,(third x
)))
685 (remove-if (lambda (x) (or (atom x
) (< (length x
) 3))) decls
)))
687 (defun do-make-iter-psteps (decls)
689 ,@(mapcan (lambda (x) (list (first x
) (third x
)))
690 (remove-if (lambda (x) (or (atom x
) (< (length x
) 3))) decls
))))
692 (defpsmacro do
* (decls (termination &optional
(result nil result?
)) &body body
)
695 (for ,(do-make-for-vars/init decls
) ((not ,termination
)) ,(do-make-for-steps decls
)
699 (for ,(do-make-for-vars/init decls
) ((not ,termination
)) ,(do-make-for-steps decls
)
702 (defpsmacro do
(decls (termination &optional
(result nil result?
)) &body body
)
704 `((lambda ,(do-make-init-vars decls
)
705 (for () ((not ,termination
)) ()
707 ,(do-make-iter-psteps decls
))
709 ,@(do-make-init-vals decls
))
710 `(let ,(do-make-let-bindings decls
)
711 (for () ((not ,termination
)) ()
713 ,(do-make-iter-psteps decls
)))))
715 (define-ps-special-form for-in
(expecting decl
&rest body
)
716 (declare (ignore expecting
))
718 (compile-parenscript-form (first decl
) :expecting
:expression
)
719 (compile-parenscript-form (second decl
) :expecting
:expression
)
720 (compile-parenscript-form `(progn ,@body
))))
722 (defpsmacro doeach
((var array
&optional
(result (values) result?
)) &body body
)
723 "Iterates over `array'. If `var' is a symbol, binds `var' to each
724 element key. If `var' is a list, it must be a list of two
725 symbols, (key value), which will be bound to each successive key/value
729 (destructuring-bind (key val
) var
732 (for-in ((var ,key
) ,array
)
733 (setf ,val
(aref ,array
,key
))
737 (for-in ((var ,var
) ,array
)
741 (destructuring-bind (key val
) var
744 (for-in ((var ,key
) ,array
)
745 (setf ,val
(aref ,array
,key
))
748 (for-in ((var ,var
) ,array
) ,@body
)))))
750 (define-ps-special-form while
(expecting test
&rest body
)
751 (declare (ignore expecting
))
752 (list 'js-while
(compile-parenscript-form test
:expecting
:expression
)
753 (compile-parenscript-form `(progn ,@body
))))
755 (defpsmacro dotimes
((var count
&optional
(result nil result?
)) &rest body
)
756 `(do* ((,var
0 (1+ ,var
)))
757 ((>= ,var
,count
) ,@(when result?
(list result
)))
760 (defpsmacro dolist
((var array
&optional
(result nil result?
)) &body body
)
761 (let ((idx (ps-gensym "_js_idx"))
762 (arrvar (ps-gensym "_js_arrvar")))
766 ((>= ,idx
(slot-value ,arrvar
'length
))
767 ,@(when result?
(list result
)))
768 (setq ,var
(aref ,arrvar
,idx
))
771 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
773 (define-ps-special-form with
(expecting expression
&rest body
)
774 (declare (ignore expecting
))
775 (list 'js-with
(compile-parenscript-form expression
:expecting
:expression
)
776 (compile-parenscript-form `(progn ,@body
))))
778 (define-ps-special-form try
(expecting form
&rest clauses
)
779 (declare (ignore expecting
))
780 (let ((catch (cdr (assoc :catch clauses
)))
781 (finally (cdr (assoc :finally clauses
))))
782 (assert (not (cdar catch
)) nil
"Sorry, currently only simple catch forms are supported.")
783 (assert (or catch finally
) ()
784 "Try form should have either a catch or a finally clause or both.")
785 (list 'js-try
(compile-parenscript-form `(progn ,form
))
786 :catch
(when catch
(list (compile-parenscript-form (caar catch
) :expecting
:symbol
)
787 (compile-parenscript-form `(progn ,@(cdr catch
)))))
788 :finally
(when finally
(compile-parenscript-form `(progn ,@finally
))))))
790 (define-ps-special-form cc-if
(expecting test
&rest body
)
791 (declare (ignore expecting
))
792 (list 'cc-if test
(mapcar #'compile-parenscript-form body
)))
794 (define-ps-special-form regex
(expecting regex
)
795 (declare (ignore expecting
))
796 (list 'js-regex
(string regex
)))
798 (define-ps-special-form lisp
(expecting lisp-form
)
799 ;; (ps (foo (lisp bar))) is in effect equivalent to (ps* `(foo ,bar))
800 ;; when called from inside of ps*, lisp-form has access only to the dynamic environment (like for eval)
801 (declare (ignore expecting
))
802 (list 'js-escape lisp-form
))