1 (in-package :parenscript
)
3 ;;;; The macrology of the Parenscript language. Special forms and macros.
5 ;;; parenscript gensyms
6 (defvar *gen-script-name-counter
* 0)
8 (defun gen-script-name-string (&key
(prefix "_js_"))
9 "Generates a unique valid javascript identifier ()"
11 prefix
(princ-to-string (incf *gen-script-name-counter
*))))
13 (defun gen-script-name (&key
(prefix ""))
14 "Generate a new javascript identifier."
15 (intern (gen-script-name-string :prefix prefix
)
16 (find-package :parenscript.ps-gensyms
)))
18 (defmacro gen-ps-name
(&rest args
)
19 `(gen-script-name ,@args
))
21 (defmacro with-unique-ps-names
(symbols &body body
)
22 "Evaluate BODY with the variables on SYMBOLS bound to new javascript identifiers.
24 Each element of SYMBOLS is either a symbol or a list of (symbol
26 `(let* ,(mapcar (lambda (symbol)
27 (destructuring-bind (symbol &optional prefix
)
32 `(,symbol
(gen-script-name :prefix
,prefix
))
33 `(,symbol
(gen-script-name)))))
37 (defvar *var-counter
* 0)
39 (defun script-gensym (&optional
(name "js"))
40 (intern (format nil
"tmp-~A-~A" name
(incf *var-counter
*)) #.
*package
*))
42 (defscriptmacro defaultf
(place value
)
43 `(setf ,place
(or (and (=== undefined
,place
) ,place
)
47 (defscriptmacro list
(&rest values
)
50 (defscriptmacro make-array
(&rest inits
)
51 `(new (*array
,@inits
)))
54 (define-script-special-form eval-when
(&rest args
)
55 "(eval-when form-language? (situation*) form*)
57 The given forms are evaluated only during the given SITUATION in the specified
58 FORM-LANGUAGE (either :lisp or :parenscript, def, defaulting to :lisp during
59 -toplevel and :parenscript during :execute). The accepted SITUATIONS are :execute,
60 :scan-toplevel. :scan-toplevel is the phase of compilation when function definitions
61 and the like are being added to the compilation environment. :execute is the phase when
62 the code is being evaluated by a Javascript engine."
63 (multiple-value-bind (body-language situations subforms
)
64 (process-eval-when-args args
)
65 ; (format t "~A~%~A~%"
66 ; (and (compiler-in-situation-p *compilation-environment* :compile-toplevel)
67 ; (find :compile-toplevel situations))
68 ; (compiler-in-situation-p *compilation-environment* :execute)
69 ; (find :execute situations))
71 ((and (compiler-in-situation-p *compilation-environment
* :compile-toplevel
)
72 (find :compile-toplevel situations
))
73 (error "Should never be processing eval-when :COMPILE-TOPLEVEL forms from here."))
75 ((and (compiler-in-situation-p *compilation-environment
* :execute
)
76 (find :execute situations
))
77 (when (eql body-language
:parenscript
)
78 (let ((form `(progn ,@subforms
)))
79 ; (format t "Form: ~A~%" form)
80 (compile-to-statement form
)))))))
83 (defscriptmacro defpackage
(name &rest options
)
84 "Defines a Parenscript package."
85 (labels ((opt-name (opt) (if (listp opt
) (car opt
) opt
)))
86 (let ((nicknames nil
) (lisp-package nil
) (secondary-lisp-packages nil
)
87 (exports nil
) (used-packages nil
) (documentation nil
))
90 (:lisp-package
(setf lisp-package
(second opt
)))
91 (:nicknames
(setf nicknames
(rest opt
)))
92 (:secondary-lisp-packages secondary-lisp-packages t
)
93 (:export
(setf exports
(rest opt
)))
94 (:use
(setf used-packages
(rest opt
)))
95 (:documentation
(setf documentation
(second opt
)))
96 (t (error "Unknown option in DEFPACKAGE: ~A" (opt-name opt
)))))
97 (create-script-package
98 *compilation-environment
*
101 :secondary-lisp-packages secondary-lisp-packages
102 :used-packages used-packages
103 :lisp-package lisp-package
105 :documentation documentation
)))
108 (defscriptmacro in-package
(package-designator)
109 "Changes the current script package in the parenscript compilation environment. This mostly
110 affects the reader and how it interns non-prefixed symbols"
111 (let ((script-package
112 (find-script-package package-designator
*compilation-environment
*)))
113 (when (null script-package
)
114 (error "~A does not designate any script package. Available script package: ~A"
116 (mapcar #'script-package-name
(comp-env-script-packages *compilation-environment
*))))
117 (setf (comp-env-current-package *compilation-environment
*)
121 (defscriptmacro case
(value &rest clauses
)
122 (labels ((make-clause (val body more
)
124 (append (mapcar #'list
(butlast val
))
125 (make-clause (first (last val
)) body more
)))
126 ((member val
'(t otherwise
))
127 (make-clause 'default body more
))
128 (more `((,val
,@body break
)))
129 (t `((,val
,@body
))))))
130 `(switch ,value
,@(mapcon #'(lambda (x)
131 (make-clause (car (first x
))
137 (define-script-special-form let
(decls &rest body
)
138 (let ((defvars (mapcar #'(lambda (decl)
140 (make-instance 'ps-js
::js-defvar
141 :names
(list (compile-to-symbol decl
))
143 (let ((name (first decl
))
144 (value (second decl
)))
145 (make-instance 'ps-js
::js-defvar
146 :names
(list (compile-to-symbol name
))
147 :value
(compile-to-expression value
)))))
149 (make-instance 'ps-js
::js-sub-block
151 :statements
(nconc defvars
152 (mapcar #'compile-to-statement body
)))))
155 (defscriptmacro dotimes
(iter &rest body
)
156 (let ((var (first iter
))
157 (times (second iter
)))
158 `(do ((,var
0 (1+ ,var
)))
162 (defscriptmacro dolist
(i-array &rest body
)
163 (let ((var (first i-array
))
164 (array (second i-array
))
165 (arrvar (script-gensym "arr"))
166 (idx (script-gensym "i")))
167 `(let ((,arrvar
,array
))
168 (do ((,idx
0 (1+ ,idx
)))
169 ((>= ,idx
(slot-value ,arrvar
'length
)))
170 (let ((,var
(aref ,arrvar
,idx
)))
174 (defmacro with-temp-macro-environment
((var) &body body
)
175 `(let* ((,var
(make-macro-env-dictionary))
176 (*script-macro-env
* (cons ,var
*script-macro-env
*)))
179 (define-script-special-form macrolet
(macros &body body
)
180 (with-temp-macro-environment (macro-env-dict)
181 (dolist (macro macros
)
182 (destructuring-bind (name arglist
&body body
)
184 (setf (get-macro-spec name macro-env-dict
)
185 (cons nil
(let ((args (gensym "ps-macrolet-args-")))
186 (compile nil
`(lambda (&rest
,args
)
187 (destructuring-bind ,arglist
190 (compile-script-form `(progn ,@body
))))
192 (define-script-special-form symbol-macrolet
(symbol-macros &body body
)
193 (with-temp-macro-environment (macro-env-dict)
194 (dolist (macro symbol-macros
)
195 (destructuring-bind (name &body expansion
)
197 (setf (get-macro-spec name macro-env-dict
)
198 (cons t
(compile nil
`(lambda () ,@expansion
))))))
199 (compile-script-form `(progn ,@body
))))
201 (defscriptmacro defmacro
(name args
&body body
)
202 `(lisp (defscriptmacro ,name
,args
,@body
) nil
))
204 (defscriptmacro define-symbol-macro
(name &body body
)
205 `(lisp (define-script-symbol-macro ,name
,@body
)))
207 (defscriptmacro lisp
(&body forms
)
208 "Evaluates the given forms in Common Lisp at ParenScript
209 macro-expansion time. The value of the last form is treated as a
210 ParenScript expression and is inserted into the generated Javascript
211 \(use nil for no-op)."
212 (eval (cons 'progn forms
)))
214 (defscriptmacro rebind
(variables &body body
)
215 "Creates a new js lexical environment and copies the given
216 variable(s) there. Executes the body in the new environment. This
217 has the same effect as a new (let () ...) form in lisp but works on
218 the js side for js closures."
219 (unless (listp variables
)
220 (setf variables
(list variables
)))
222 (let ((new-context (new *object
)))
223 ,@(loop for variable in variables
224 collect
`(setf (slot-value new-context
,(symbol-to-js variable
))
229 (defscriptmacro with-slots
(slots object
&rest body
)
230 (flet ((slot-var (slot) (if (listp slot
) (first slot
) slot
))
231 (slot-symbol (slot) (if (listp slot
) (second slot
) slot
)))
232 `(symbol-macrolet ,(mapcar #'(lambda (slot)
233 `(,(slot-var slot
) '(slot-value ,object
',(slot-symbol slot
))))
237 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
238 (defun parse-function-body (body)
239 ;; (format t "parsing function body ~A~%" body)
240 (let* ((documentation
241 (when (stringp (first body
))
243 (body-forms (if documentation
(rest body
) body
)))
248 (defun parse-key-spec (key-spec)
249 "parses an &key parameter. Returns 4 values:
250 var, init-form, keyword-name, supplied-p-var, init-form-supplied-p.
253 [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}*
255 (let* ((var (cond ((symbolp key-spec
) key-spec
)
256 ((and (listp key-spec
) (symbolp (first key-spec
))) (first key-spec
))
257 ((and (listp key-spec
) (listp (first key-spec
))) (second key-spec
))))
258 (keyword-name (if (and (listp key-spec
) (listp (first key-spec
)))
259 (first (first key-spec
))
260 (intern (string var
) :keyword
)))
261 (init-form (if (listp key-spec
) (second key-spec
) nil
))
262 (init-form-supplied-p (if (listp key-spec
) t nil
))
263 (supplied-p-var (if (listp key-spec
) (third key-spec
) nil
)))
264 (values var init-form keyword-name supplied-p-var init-form-supplied-p
)))
266 (defun parse-optional-spec (spec)
267 "Parses an &optional parameter. Returns 3 values: var, init-form, supplied-p-var.
268 [&optional {var | (var [init-form [supplied-p-parameter]])}*] "
269 (let* ((var (cond ((symbolp spec
) spec
)
270 ((and (listp spec
) (first spec
)))))
271 (init-form (if (listp spec
) (second spec
)))
272 (supplied-p-var (if (listp spec
) (third spec
))))
273 (values var init-form supplied-p-var
)))
275 (defun parse-aux-spec (spec)
276 "Returns two values: variable and init-form"
277 ;; [&aux {var | (var [init-form])}*])
278 (values (if (symbolp spec
) spec
(first spec
))
279 (when (listp spec
) (second spec
))))
281 (defun parse-extended-function (lambda-list body
&optional name
)
282 "Returns two values: the effective arguments and body for a function with
283 the given lambda-list and body."
285 ;; The lambda list is transformed as follows, since a javascript lambda list is just a
286 ;; list of variable names, and you have access to the arguments variable inside the function:
287 ;; * standard variables are the mapped directly into the js-lambda list
288 ;; * optional variables' variable names are mapped directly into the lambda list,
289 ;; and for each optional variable with name v and default value d, a form is produced
291 ;; * when any keyword variables are in the lambda list, a single 'options' variable is
292 ;; appended to the js-lambda list as the last argument. WITH-SLOTS is used for all
293 ;; the variables with inside the body of the function,
294 ;; a (with-slots ((var-name key-name)) options ...)
295 (declare (ignore name
))
296 (multiple-value-bind (requireds optionals rest? rest keys? keys
)
297 (parse-lambda-list lambda-list
)
298 ;; (format t "~A .." rest)
299 (let* ((options-var 'options
)
300 ;; optionals are of form (var default-value)
305 (mapcar #'parse-optional-spec optionals
)
306 (when keys
(list options-var
)))))
307 ;; an alist of arg -> default val
312 ;; optional arguments first
313 (mapcar #'(lambda (opt-spec)
314 (multiple-value-bind (var val
) (parse-optional-spec opt-spec
)
317 (if keys?
(list (cons options-var
'(create))))
318 (mapcar #'(lambda (key-spec)
319 (multiple-value-bind (var val x y specified?
) (parse-key-spec key-spec
)
320 (declare (ignore x y
))
321 (when specified?
(cons var val
))))
323 (body-paren-forms (parse-function-body body
)) ;remove documentation
326 (mapcar #'(lambda (default-pair)
327 `(defaultf ,(car default-pair
) ,(cdr default-pair
)))
331 `(defvar ,rest
(:.slice
(to-array arguments
)
332 ,(length effective-args
)))
334 (effective-body (append initform-forms
(list rest-form
) body-paren-forms
))
337 (list `(with-slots ,(mapcar #'(lambda (key-spec)
338 (multiple-value-bind (var x key-name
)
339 (parse-key-spec key-spec
)
341 (list var key-name
)))
346 (values effective-args effective-body
)))))
348 (ps:defscriptmacro defun
(name lambda-list
&body body
)
349 "An extended defun macro that allows cool things like keyword arguments.
352 [&optional {var | (var [init-form [supplied-p-parameter]])}*]
354 [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
355 [&aux {var | (var [init-form])}*])"
356 (multiple-value-bind (effective-args effective-body
)
357 (parse-extended-function lambda-list body name
)
358 `(%js-defun
,name
,effective-args
362 (ps:defscriptmacro lambda
(lambda-list &body body
)
363 "An extended defun macro that allows cool things like keyword arguments.
366 [&optional {var | (var [init-form [supplied-p-parameter]])}*]
368 [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
369 [&aux {var | (var [init-form])}*])"
370 (multiple-value-bind (effective-args effective-body
)
371 (parse-extended-function lambda-list body
)
372 `(%js-lambda
,effective-args
375 (defpsmacro defsetf
(access-fn lambda-list
(store-var) form
)
376 (setf (find-macro-spec access-fn
*script-setf-expanders
*)
378 (let ((var-bindings (set-difference lambda-list lambda-list-keywords
)))
379 `(lambda (access-fn-args store-form
)
380 (destructuring-bind ,lambda-list
382 (let* ((,store-var
(ps:gen-ps-name
))
383 (gensymed-names (loop repeat
,(length var-bindings
) collecting
(ps:gen-ps-name
)))
384 (gensymed-arg-bindings (mapcar #'list gensymed-names
(list ,@var-bindings
))))
385 (destructuring-bind ,var-bindings
387 `(let ((,,store-var
,store-form
)
388 ,@gensymed-arg-bindings
)
392 (defpsmacro setf
(&rest args
)
393 (flet ((process-setf-clause (place value-form
)
394 (if (and (listp place
) (find-macro-spec (car place
) *script-setf-expanders
*))
395 (funcall (find-macro-spec (car place
) *script-setf-expanders
*) (cdr place
) value-form
)
396 (let ((exp-place (expand-script-form place
)))
397 (if (and (listp exp-place
) (find-macro-spec (car exp-place
) *script-setf-expanders
*))
398 (funcall (find-macro-spec (car exp-place
) *script-setf-expanders
*) (cdr exp-place
) value-form
)
399 `(parenscript.javascript
::setf1%
,exp-place
,value-form
))))))
400 (assert (evenp (length args
)) ()
401 "~s does not have an even number of arguments." (cons 'setf args
))
402 `(progn ,@(loop for
(place value
) on args by
#'cddr collect
(process-setf-clause place value
)))))