1 (in-package :parenscript
)
3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
5 (defmacro defpsliteral
(name string
)
6 `(progn (pushnew ',name
*ps-literals
*)
7 (define-ps-special-form ,name
(expecting)
8 (declare (ignore expecting
))
9 (list 'js-literal
,string
))))
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")
19 (defpsliteral break
"break")
20 (defpsliteral continue
"continue")
22 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
24 (mapcar (lambda (op) (eval `(define-ps-special-form ,op
(expecting value
)
25 (declare (ignore expecting
))
26 (list 'js-named-operator
',op
(compile-parenscript-form value
)))))
27 '(throw delete void typeof new
))
29 (define-ps-special-form return
(expecting &optional value
)
30 (declare (ignore expecting
))
31 (list 'js-return
(compile-parenscript-form value
:expecting
:expression
)))
33 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
35 (define-ps-special-form array
(expecting &rest values
)
36 (declare (ignore expecting
))
37 (cons 'array-literal
(mapcar (lambda (form) (compile-parenscript-form form
:expecting
:expression
))
40 (define-ps-special-form aref
(expecting array
&rest coords
)
41 (declare (ignore expecting
))
42 (list 'js-aref
(compile-parenscript-form array
:expecting
:expression
)
43 (mapcar (lambda (form)
44 (compile-parenscript-form form
:expecting
:expression
))
47 (define-ps-special-form {} (expecting &rest arrows
)
48 (declare (ignore expecting
))
49 (cons 'object-literal
(loop for
(key value
) on arrows by
#'cddr
50 collect
(cons key
(compile-parenscript-form value
:expecting
:expression
)))))
52 (defpsmacro list
(&rest values
)
55 (defpsmacro make-array
(&rest inits
)
56 `(new (*array
,@inits
)))
58 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
60 (define-ps-special-form incf
(expecting x
&optional
(delta 1))
61 (declare (ignore expecting
))
63 (list 'unary-operator
"++" (compile-parenscript-form x
:expecting
:expression
) :prefix t
)
64 (list 'operator
'+= (list (compile-parenscript-form x
:expecting
:expression
)
65 (compile-parenscript-form delta
:expecting
:expression
)))))
67 (define-ps-special-form decf
(expecting x
&optional
(delta 1))
68 (declare (ignore expecting
))
70 (list 'unary-operator
"--" (compile-parenscript-form x
:expecting
:expression
) :prefix t
)
71 (list 'operator
'-
= (list (compile-parenscript-form x
:expecting
:expression
)
72 (compile-parenscript-form delta
:expecting
:expression
)))))
74 (define-ps-special-form -
(expecting first
&rest rest
)
75 (declare (ignore expecting
))
77 (list 'unary-operator
"-" (compile-parenscript-form first
:expecting
:expression
) :prefix t
)
78 (list 'operator
'-
(mapcar (lambda (val) (compile-parenscript-form val
:expecting
:expression
))
81 (define-ps-special-form not
(expecting x
)
82 (declare (ignore expecting
))
83 (let ((form (compile-parenscript-form x
:expecting
:expression
))
85 (if (and (eql (first form
) 'operator
)
86 (= (length (third form
)) 2)
87 (setf not-op
(case (second form
)
97 (list 'operator not-op
(third form
))
98 (list 'unary-operator
"!" form
:prefix t
))))
100 (define-ps-special-form ~
(expecting x
)
101 (declare (ignore expecting
))
102 (list 'unary-operator
"~" (compile-parenscript-form x
:expecting
:expression
) :prefix t
))
104 (defpsmacro 1-
(form)
107 (defpsmacro 1+ (form)
110 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
111 ;;; control structures
112 (defun flatten-blocks (body)
114 (if (and (listp (car body
))
115 (eql 'js-block
(caar body
)))
116 (append (third (car body
)) (flatten-blocks (cdr body
)))
117 (cons (car body
) (flatten-blocks (cdr body
))))))
119 (defun constant-literal-form-p (form)
123 (eql 'js-literal
(car form
)))))
125 (define-ps-special-form progn
(expecting &rest body
)
126 (if (and (eql expecting
:expression
) (= 1 (length body
)))
127 (compile-parenscript-form (car body
) :expecting
:expression
)
130 (let* ((block (mapcar (lambda (form)
131 (compile-parenscript-form form
:expecting expecting
))
133 (clean-block (remove nil block
))
134 (flat-block (flatten-blocks clean-block
))
135 (reachable-block (append (remove-if #'constant-literal-form-p
(butlast flat-block
))
139 (define-ps-special-form cond
(expecting &rest clauses
)
141 (:statement
(list 'js-cond-statement
142 (mapcar (lambda (clause)
143 (destructuring-bind (test &rest body
)
145 (list (compile-parenscript-form test
:expecting
:expression
)
146 (compile-parenscript-form `(progn ,@body
) :expecting
:statement
))))
148 (:expression
(make-cond-clauses-into-nested-ifs clauses
))))
150 (defun make-cond-clauses-into-nested-ifs (clauses)
152 (destructuring-bind (test &rest body
)
155 (compile-parenscript-form `(progn ,@body
) :expecting
:expression
)
156 (list 'js-expression-if
(compile-parenscript-form test
:expecting
:expression
)
157 (compile-parenscript-form `(progn ,@body
) :expecting
:expression
)
158 (make-cond-clauses-into-nested-ifs (cdr clauses
)))))
159 (compile-parenscript-form nil
:expecting
:expression
)))
161 (define-ps-special-form if
(expecting test then
&optional else
)
163 (:statement
(list 'js-statement-if
(compile-parenscript-form test
:expecting
:expression
)
164 (compile-parenscript-form `(progn ,then
))
165 (when else
(compile-parenscript-form `(progn ,else
)))))
166 (:expression
(list 'js-expression-if
(compile-parenscript-form test
:expecting
:expression
)
167 (compile-parenscript-form then
:expecting
:expression
)
168 (compile-parenscript-form else
:expecting
:expression
)))))
170 (define-ps-special-form switch
(expecting test-expr
&rest clauses
)
171 (declare (ignore expecting
))
172 (let ((clauses (mapcar (lambda (clause)
173 (let ((val (car clause
))
175 (cons (if (eql val
'default
)
177 (compile-parenscript-form val
:expecting
:expression
))
178 (mapcar (lambda (statement) (compile-parenscript-form statement
:expecting
:statement
))
181 (expr (compile-parenscript-form test-expr
:expecting
:expression
)))
182 (list 'js-switch expr clauses
)))
184 (defpsmacro case
(value &rest clauses
)
185 (labels ((make-clause (val body more
)
187 (append (mapcar #'list
(butlast val
))
188 (make-clause (first (last val
)) body more
)))
189 ((member val
'(t otherwise
))
190 (make-clause 'default body more
))
191 (more `((,val
,@body break
)))
192 (t `((,val
,@body
))))))
193 `(switch ,value
,@(mapcon (lambda (clause)
194 (make-clause (car (first clause
))
199 (defpsmacro when
(test &rest body
)
200 `(if ,test
(progn ,@body
)))
202 (defpsmacro unless
(test &rest body
)
203 `(if (not ,test
) (progn ,@body
)))
205 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
206 ;;; function definition
207 (defun compile-function-definition (args body
)
208 (list (mapcar (lambda (arg) (compile-parenscript-form arg
:expecting
:symbol
)) args
)
209 (let ((*enclosing-lexical-block-declarations
* ()))
210 ;; the first compilation will produce a list of variables we need to declare in the function body
211 (compile-parenscript-form `(progn ,@body
) :expecting
:statement
)
212 ;; now declare and compile
213 (compile-parenscript-form `(progn ,@(loop for var in
*enclosing-lexical-block-declarations
* collect
`(var ,var
))
214 ,@body
) :expecting
:statement
))))
216 (define-ps-special-form %js-lambda
(expecting args
&rest body
)
217 (declare (ignore expecting
))
218 (cons 'js-lambda
(compile-function-definition args body
)))
220 (define-ps-special-form %js-defun
(expecting name args
&rest body
)
221 (declare (ignore expecting
))
222 (append (list 'js-defun
name) (compile-function-definition args body
)))
224 (defun parse-function-body (body)
226 (when (stringp (first body
))
228 (body-forms (if docstring
(rest body
) body
)))
229 (values body-forms docstring
)))
231 (defun parse-key-spec (key-spec)
232 "parses an &key parameter. Returns 4 values:
233 var, init-form, keyword-name, supplied-p-var, init-form-supplied-p.
236 [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}*
238 (let* ((var (cond ((symbolp key-spec
) key-spec
)
239 ((and (listp key-spec
) (symbolp (first key-spec
))) (first key-spec
))
240 ((and (listp key-spec
) (listp (first key-spec
))) (second key-spec
))))
241 (keyword-name (if (and (listp key-spec
) (listp (first key-spec
)))
242 (first (first key-spec
))
243 (intern (string var
) :keyword
)))
244 (init-form (if (listp key-spec
) (second key-spec
) nil
))
245 (init-form-supplied-p (if (listp key-spec
) t nil
))
246 (supplied-p-var (if (listp key-spec
) (third key-spec
) nil
)))
247 (values var init-form keyword-name supplied-p-var init-form-supplied-p
)))
249 (defun parse-optional-spec (spec)
250 "Parses an &optional parameter. Returns 3 values: var, init-form, supplied-p-var.
251 [&optional {var | (var [init-form [supplied-p-parameter]])}*] "
252 (let* ((var (cond ((symbolp spec
) spec
)
253 ((and (listp spec
) (first spec
)))))
254 (init-form (if (listp spec
) (second spec
)))
255 (supplied-p-var (if (listp spec
) (third spec
))))
256 (values var init-form supplied-p-var
)))
258 (defun parse-aux-spec (spec)
259 "Returns two values: variable and init-form"
260 ;; [&aux {var | (var [init-form])}*])
261 (values (if (symbolp spec
) spec
(first spec
))
262 (when (listp spec
) (second spec
))))
264 (defpsmacro defaultf
(place value
)
265 `(setf ,place
(or (and (=== undefined
,place
) ,value
)
268 (defun parse-extended-function (lambda-list body
&optional name
)
269 "Returns two values: the effective arguments and body for a function with
270 the given lambda-list and body."
272 ;; The lambda list is transformed as follows, since a javascript lambda list is just a
273 ;; list of variable names, and you have access to the arguments variable inside the function:
274 ;; * standard variables are the mapped directly into the js-lambda list
275 ;; * optional variables' variable names are mapped directly into the lambda list,
276 ;; and for each optional variable with name v and default value d, a form is produced
278 ;; * when any keyword variables are in the lambda list, a single 'optional-args' variable is
279 ;; appended to the js-lambda list as the last argument. WITH-SLOTS is used for all
280 ;; the variables with inside the body of the function,
281 ;; a (with-slots ((var-name key-name)) optional-args ...)
282 (declare (ignore name
))
283 (multiple-value-bind (requireds optionals rest? rest keys? keys allow? aux? aux
284 more? more-context more-count key-object
)
285 (parse-lambda-list lambda-list
)
286 (declare (ignore allow? aux? aux more? more-context more-count
))
287 (let* ((options-var (or key-object
(ps-gensym)))
288 ;; optionals are of form (var default-value)
293 (mapcar #'parse-optional-spec optionals
)
294 (when keys
(list options-var
)))))
295 ;; an alist of arg -> default val
300 ;; optional arguments first
301 (mapcar #'(lambda (opt-spec)
302 (multiple-value-bind (var val
) (parse-optional-spec opt-spec
)
305 (if keys?
(list (cons options-var
'(create))))
306 (mapcar #'(lambda (key-spec)
307 (multiple-value-bind (var val x y specified?
) (parse-key-spec key-spec
)
308 (declare (ignore x y
))
309 (when specified?
(cons var val
))))
311 (body-paren-forms (parse-function-body body
)) ;remove documentation
314 (mapcar #'(lambda (default-pair)
315 `(defaultf ,(car default-pair
) ,(cdr default-pair
)))
320 `(progn (var ,rest
(array))
321 (dotimes (,i
(- arguments.length
,(length effective-args
)))
322 (setf (aref ,rest
,i
) (aref arguments
(+ ,i
,(length effective-args
)))))))
324 (effective-body (append initform-forms
(list rest-form
) body-paren-forms
))
327 (list `(with-slots ,(mapcar #'(lambda (key-spec)
328 (multiple-value-bind (var x key-name
)
329 (parse-key-spec key-spec
)
331 (list var key-name
)))
336 (values effective-args effective-body
))))
338 (defpsmacro defun
(name lambda-list
&body body
)
339 "An extended defun macro that allows cool things like keyword arguments.
342 [&optional {var | (var [init-form [supplied-p-parameter]])}*]
344 [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
345 [&aux {var | (var [init-form])}*])"
347 `(defun-function ,name
,lambda-list
,@body
)
348 (progn (assert (and (= (length name
) 2) (eql 'setf
(car name
))) ()
349 "(defun ~s ~s ...) needs to have a symbol or (setf symbol) for a name." name lambda-list
)
350 `(defun-setf ,name
,lambda-list
,@body
))))
352 (defpsmacro defun-function
(name lambda-list
&body body
)
353 (multiple-value-bind (effective-args effective-body
)
354 (parse-extended-function lambda-list body name
)
355 `(%js-defun
,name
,effective-args
358 (defvar *defun-setf-name-prefix
* "__setf_")
360 (defpsmacro defun-setf
(setf-name lambda-list
&body body
)
361 (let ((mangled-function-name (intern (concatenate 'string
*defun-setf-name-prefix
* (symbol-name (second setf-name
)))
362 (symbol-package (second setf-name
))))
363 (function-args (cdr (ordered-set-difference lambda-list lambda-list-keywords
))))
364 `(progn (defsetf ,(second setf-name
) ,(cdr lambda-list
) (store-var)
365 `(,',mangled-function-name
,store-var
,@(list ,@function-args
)))
366 (defun ,mangled-function-name
,lambda-list
,@body
))))
368 (defpsmacro lambda
(lambda-list &body body
)
369 "An extended defun macro that allows cool things like keyword arguments.
372 [&optional {var | (var [init-form [supplied-p-parameter]])}*]
374 [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
375 [&aux {var | (var [init-form])}*])"
376 (multiple-value-bind (effective-args effective-body
)
377 (parse-extended-function lambda-list body
)
378 `(%js-lambda
,effective-args
381 (defpsmacro defsetf-long
(access-fn lambda-list
(store-var) form
)
382 (setf (get-macro-spec access-fn
*script-setf-expanders
*)
384 (let ((var-bindings (ordered-set-difference lambda-list lambda-list-keywords
)))
385 `(lambda (access-fn-args store-form
)
386 (destructuring-bind ,lambda-list
388 (let* ((,store-var
(ps-gensym))
389 (gensymed-names (loop repeat
,(length var-bindings
) collecting
(ps-gensym)))
390 (gensymed-arg-bindings (mapcar #'list gensymed-names
(list ,@var-bindings
))))
391 (destructuring-bind ,var-bindings
393 `(let* (,@gensymed-arg-bindings
394 (,,store-var
,store-form
))
398 (defpsmacro defsetf-short
(access-fn update-fn
&optional docstring
)
399 (declare (ignore docstring
))
400 (setf (get-macro-spec access-fn
*script-setf-expanders
*)
401 (lambda (access-fn-args store-form
)
402 `(,update-fn
,@access-fn-args
,store-form
)))
405 (defpsmacro defsetf
(access-fn &rest args
)
406 `(,(if (= (length args
) 3) 'defsetf-long
'defsetf-short
) ,access-fn
,@args
))
408 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
410 (defmacro with-temp-macro-environment
((var) &body body
)
411 `(let* ((,var
(make-macro-env-dictionary))
412 (*script-macro-env
* (cons ,var
*script-macro-env
*)))
415 (define-ps-special-form macrolet
(expecting macros
&body body
)
416 (declare (ignore expecting
))
417 (with-temp-macro-environment (macro-env-dict)
418 (dolist (macro macros
)
419 (destructuring-bind (name arglist
&body body
)
421 (setf (get-macro-spec name macro-env-dict
)
422 (cons nil
(make-ps-macro-function arglist body
)))))
423 (compile-parenscript-form `(progn ,@body
))))
425 (define-ps-special-form symbol-macrolet
(expecting symbol-macros
&body body
)
426 (declare (ignore expecting
))
427 (with-temp-macro-environment (macro-env-dict)
428 (dolist (macro symbol-macros
)
429 (destructuring-bind (name expansion
)
431 (setf (get-macro-spec name macro-env-dict
)
432 (cons t
(make-ps-macro-function () (list `',expansion
))))))
433 (compile-parenscript-form `(progn ,@body
))))
435 (define-ps-special-form defmacro
(expecting name args
&body body
)
436 (declare (ignore expecting
))
437 (define-script-macro% name args body
:symbol-macro-p nil
)
440 (define-ps-special-form define-symbol-macro
(expecting name expansion
)
441 (declare (ignore expecting
))
442 (define-script-macro% name
() (list `',expansion
) :symbol-macro-p t
)
445 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
447 (define-ps-special-form create
(expecting &rest args
)
448 (declare (ignore expecting
))
449 (list 'js-object
(loop for
(name val
) on args by
#'cddr collecting
450 (let ((name-expr (compile-parenscript-form name
:expecting
:expression
)))
451 (assert (or (stringp name-expr
)
453 (and (listp name-expr
)
454 (or (eql 'js-variable
(car name-expr
))
455 (eql 'script-quote
(car name-expr
)))))
457 "Slot ~s is not one of js-variable, keyword, string or number." name-expr
)
458 (list name-expr
(compile-parenscript-form val
:expecting
:expression
))))))
460 (define-ps-special-form %js-slot-value
(expecting obj slot
)
461 (declare (ignore expecting
))
462 (if (ps::ps-macroexpand slot
)
463 (list 'js-slot-value
(compile-parenscript-form obj
:expecting
:expression
) (compile-parenscript-form slot
))
464 (compile-parenscript-form obj
:expecting
:expression
)))
466 (define-ps-special-form instanceof
(expecting value type
)
467 (declare (ignore expecting
))
468 (list 'js-instanceof
(compile-parenscript-form value
:expecting
:expression
)
469 (compile-parenscript-form type
:expecting
:expression
)))
471 (defpsmacro slot-value
(obj &rest slots
)
472 (if (null (rest slots
))
473 `(%js-slot-value
,obj
,(first slots
))
474 `(slot-value (slot-value ,obj
,(first slots
)) ,@(rest slots
))))
476 (defpsmacro with-slots
(slots object
&rest body
)
477 (flet ((slot-var (slot) (if (listp slot
) (first slot
) slot
))
478 (slot-symbol (slot) (if (listp slot
) (second slot
) slot
)))
479 `(symbol-macrolet ,(mapcar #'(lambda (slot)
480 `(,(slot-var slot
) (slot-value ,object
',(slot-symbol slot
))))
484 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
485 ;;; assignment and binding
486 (defun assignment-op (op)
502 (defun smart-setf (lhs rhs
)
504 (eql 'operator
(car rhs
))
505 (member lhs
(third rhs
) :test
#'equalp
))
506 (let ((args-without-first (remove lhs
(third rhs
) :count
1 :end
1 :test
#'equalp
)))
507 (cond ((and (assignment-op (second rhs
))
508 (member (second rhs
) '(+ *))
509 (equalp lhs
(first (third rhs
))))
510 (list 'operator
(assignment-op (second rhs
))
511 (list lhs
(list 'operator
(second rhs
) args-without-first
))))
512 (t (list 'js-assign lhs rhs
))))
513 (list 'js-assign lhs rhs
)))
515 (define-ps-special-form setf1%
(expecting lhs rhs
)
516 (declare (ignore expecting
))
517 (smart-setf (compile-parenscript-form lhs
:expecting
:expression
) (compile-parenscript-form rhs
:expecting
:expression
)))
519 (defpsmacro setf
(&rest args
)
520 (flet ((process-setf-clause (place value-form
)
521 (if (and (listp place
) (get-macro-spec (car place
) *script-setf-expanders
*))
522 (funcall (get-macro-spec (car place
) *script-setf-expanders
*) (cdr place
) value-form
)
523 (let ((exp-place (ps-macroexpand place
)))
524 (if (and (listp exp-place
) (get-macro-spec (car exp-place
) *script-setf-expanders
*))
525 (funcall (get-macro-spec (car exp-place
) *script-setf-expanders
*) (cdr exp-place
) value-form
)
526 `(setf1%
,exp-place
,value-form
))))))
527 (assert (evenp (length args
)) ()
528 "~s does not have an even number of arguments." (cons 'setf args
))
529 `(progn ,@(loop for
(place value
) on args by
#'cddr collect
(process-setf-clause place value
)))))
531 (define-ps-special-form var
(expecting name
&rest value
)
532 (declare (ignore expecting
))
533 (append (list 'js-var name
)
535 (assert (= (length value
) 1) () "Wrong number of arguments to var: ~s" `(var ,name
,@value
))
536 (list (compile-parenscript-form (car value
) :expecting
:expression
)))))
538 (defpsmacro defvar
(name &rest value
)
539 "Note: this must be used as a top-level form, otherwise the result will be undefined behavior."
540 (pushnew name
*ps-special-variables
*)
541 (assert (or (null value
) (= (length value
) 1)) () "Wrong number of arguments to defvar: ~s" `(defvar ,name
,@value
))
542 `(var ,name
,@value
))
544 (defpsmacro lexical-let
* (bindings &body body
)
545 "A let form that does actual lexical binding of variables. This is
546 currently expensive in JavaScript since we have to cons up and call a
548 (with-ps-gensyms (new-lexical-context)
550 (let* ((,new-lexical-context
(new *object
)))
551 ,@(loop for binding in bindings
552 collect
`(setf (slot-value ,new-lexical-context
,(symbol-to-js (if (atom binding
) binding
(first binding
))))
553 ,(when (listp binding
) (second binding
))))
554 (with ,new-lexical-context
,@body
))))))
556 (defpsmacro let
* (bindings &rest body
)
558 (let ((var (if (listp (car bindings
)) (caar bindings
) (car bindings
))))
559 `(,(if (member var
*ps-special-variables
*) 'let1-dynamic
'let1
) ,(car bindings
)
560 (let* ,(cdr bindings
) ,@body
)))
563 (defpsmacro let
(&rest stuff
)
564 "Right now, let doesn't do parallel assignment."
567 (define-ps-special-form let1
(expecting binding
&rest body
)
570 (compile-parenscript-form `(progn ,(if (atom binding
) `(var ,binding
) `(var ,@binding
)) ,@body
) :expecting
:statement
))
572 (let ((var (if (atom binding
) binding
(car binding
)))
573 (variable-assignment (when (listp binding
) (cons 'setf binding
))))
574 (push var
*enclosing-lexical-block-declarations
*)
575 (compile-parenscript-form `(progn ,variable-assignment
,@body
) :expecting
:expression
)))))
577 (defpsmacro let1-dynamic
((var value
) &rest body
)
578 (with-ps-gensyms (temp-stack-var)
579 `(progn (var ,temp-stack-var
)
580 (try (progn (setf ,temp-stack-var
,var
)
583 (:finally
(setf ,var
,temp-stack-var
))))))
585 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
587 (defun make-for-vars (decls)
588 (loop for decl in decls
589 for var
= (if (atom decl
) decl
(first decl
))
590 for init-value
= (if (atom decl
) nil
(second decl
))
591 collect
(cons (compile-parenscript-form var
:expecting
:symbol
) (compile-parenscript-form init-value
))))
593 (defun make-for-steps (decls)
594 (loop for decl in decls
595 when
(= (length decl
) 3)
596 collect
(compile-parenscript-form (third decl
) :expecting
:expression
)))
598 (define-ps-special-form do
(expecting decls termination-test
&rest body
)
599 (declare (ignore expecting
))
600 (let ((vars (make-for-vars decls
))
601 (steps (make-for-steps decls
))
602 (test (compile-parenscript-form `(not ,(first termination-test
)) :expecting
:expression
))
603 (body (compile-parenscript-form `(progn ,@body
))))
604 (list 'js-for vars steps test body
)))
606 (define-ps-special-form doeach
(expecting decl
&rest body
)
607 (declare (ignore expecting
))
610 (compile-parenscript-form (second decl
) :expecting
:expression
)
611 (compile-parenscript-form `(progn ,@body
))))
613 (define-ps-special-form while
(expecting test
&rest body
)
614 (declare (ignore expecting
))
615 (list 'js-while
(compile-parenscript-form test
:expecting
:expression
)
616 (compile-parenscript-form `(progn ,@body
))))
618 (defpsmacro dotimes
(iter &rest body
)
619 (let ((var (first iter
))
620 (times (second iter
)))
621 `(do ((,var
0 (1+ ,var
)))
625 (defpsmacro dolist
(i-array &rest body
)
626 (let ((var (first i-array
))
627 (array (second i-array
))
628 (arrvar (ps-gensym "tmp-arr"))
629 (idx (ps-gensym "tmp-i")))
630 `(let* ((,arrvar
,array
))
631 (do ((,idx
0 (1+ ,idx
)))
632 ((>= ,idx
(slot-value ,arrvar
'length
)))
633 (let* ((,var
(aref ,arrvar
,idx
)))
636 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
638 (define-ps-special-form with
(expecting expression
&rest body
)
639 (declare (ignore expecting
))
640 (list 'js-with
(compile-parenscript-form expression
:expecting
:expression
)
641 (compile-parenscript-form `(progn ,@body
))))
643 (define-ps-special-form try
(expecting form
&rest clauses
)
644 (declare (ignore expecting
))
645 (let ((catch (cdr (assoc :catch clauses
)))
646 (finally (cdr (assoc :finally clauses
))))
647 (assert (not (cdar catch
)) nil
"Sorry, currently only simple catch forms are supported.")
648 (assert (or catch finally
) ()
649 "Try form should have either a catch or a finally clause or both.")
650 (list 'js-try
(compile-parenscript-form `(progn ,form
))
651 :catch
(when catch
(list (compile-parenscript-form (caar catch
) :expecting
:symbol
)
652 (compile-parenscript-form `(progn ,@(cdr catch
)))))
653 :finally
(when finally
(compile-parenscript-form `(progn ,@finally
))))))
655 (define-ps-special-form cc-if
(expecting test
&rest body
)
656 (declare (ignore expecting
))
657 (list 'cc-if test
(mapcar #'compile-parenscript-form body
)))
659 (define-ps-special-form regex
(expecting regex
)
660 (declare (ignore expecting
))
661 (list 'js-regex
(string regex
)))
663 (defpsmacro lisp
(&body forms
)
664 "Evaluates the given forms in Common Lisp at ParenScript
665 macro-expansion time. The value of the last form is treated as a
666 ParenScript expression and is inserted into the generated Javascript
667 \(use nil for no-op)."
668 (eval (cons 'progn forms
)))