1 (in-package :parenscript
)
3 (defvar *ps-literals
* ())
4 (defvar *ps-special-forms
* ())
6 (defun undefine-ps-special-form (name)
7 "Undefines the special form with the given name (name is a symbol)."
8 (setf *ps-special-forms
* (delete name
*ps-special-forms
*)
9 *ps-literals
* (delete name
*ps-literals
*))
10 (unintern (lisp-symbol-to-ps-identifier name
:special-form
) :parenscript-special-forms
))
12 (defmacro define-ps-special-form
(name lambda-list
&rest body
)
13 "Define a special form NAME. The first argument given to the special
14 form is a keyword indicating whether the form is expected to produce
15 an :expression or a :statement. The resulting Parenscript language
16 types are appended to the ongoing javascript compilation."
17 (let ((arglist (gensym "ps-arglist-")))
18 `(progn (pushnew ',name
*ps-special-forms
*)
19 (defun ,(lisp-symbol-to-ps-identifier name
:special-form
) (&rest
,arglist
)
20 (destructuring-bind ,lambda-list
24 (defun get-ps-special-form (name)
25 "Returns the special form function corresponding to the given name."
26 (lisp-symbol-to-ps-identifier name
:special-form
))
28 (defvar *enclosing-lexical-block-declarations
* ()
29 "This special variable is expected to be bound to a fresh list by
30 special forms that introduce a new JavaScript lexical block (currently
31 function definitions and lambdas). Enclosed special forms are expected
32 to push variable declarations onto the list when the variables
33 declaration cannot be made by the enclosed form (for example, a
34 (x,y,z) expression progn). It is then the responsibility of the
35 enclosing special form to introduce the variable bindings in its
38 (defvar *ps-special-variables
* ())
40 ;;; ParenScript form predicates
41 (defun ps-special-form-p (form)
44 (or (member (car form
) *ps-special-forms
*)
45 (member (intern (symbol-name (car form
)) #.
(find-package :parenscript
))
46 *ps-special-forms
*))))
48 (defun ps-literal-p (symbol)
49 (or (member symbol
*ps-literals
*)
50 (member (intern (symbol-name symbol
) #.
(find-package :parenscript
))
53 (defun op-form-p (form)
55 (not (ps-special-form-p form
))
56 (not (null (op-precedence (first form
))))))
58 (defun funcall-form-p (form)
60 (not (op-form-p form
))
61 (not (ps-special-form-p form
))))
63 (defun method-call-p (form)
64 (and (funcall-form-p form
)
65 (symbolp (first form
))
66 (eql (char (symbol-name (first form
)) 0) #\.
)))
69 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
70 (defun make-macro-env-dictionary ()
71 "Creates a standard macro dictionary."
72 (make-hash-table :test
#'equal
))
73 (defvar *script-macro-toplevel
* (make-macro-env-dictionary)
74 "Toplevel macro environment dictionary. Key is the symbol of the
75 macro, value is (symbol-macro-p . expansion-function).")
76 (defvar *script-macro-env
* (list *script-macro-toplevel
*)
77 "Current macro environment.")
79 (defvar *script-setf-expanders
* (make-macro-env-dictionary)
80 "Setf expander dictionary. Key is the symbol of the access
81 function of the place, value is an expansion function that takes the
82 arguments of the access functions as a first value and the form to be
83 stored as the second value.")
85 (defun get-macro-spec (name env-dict
)
86 "Retrieves the macro spec of the given name with the given environment dictionary.
87 SPEC is of the form (symbol-macro-p . expansion-function)."
88 (gethash (lisp-symbol-to-ps-identifier name
:macro
) env-dict
))
89 (defsetf get-macro-spec
(name env-dict
)
91 `(setf (gethash (lisp-symbol-to-ps-identifier ,name
:macro
) ,env-dict
) ,spec
)))
93 (defun lookup-macro-spec (name &optional
(environment *script-macro-env
*))
94 "Looks up the macro spec associated with NAME in the given environment. A
95 macro spec is of the form (symbol-macro-p . function). Returns two values:
96 the SPEC and the parent macro environment.
98 NAME must be a symbol."
100 (do ((env environment
(cdr env
)))
102 (let ((val (get-macro-spec name
(car env
))))
104 (return-from lookup-macro-spec
105 (values val
(or (cdr env
)
106 (list *script-macro-toplevel
*)))))))))
108 (defun script-symbol-macro-p (name &optional
(environment *script-macro-env
*))
109 "True if there is a Parenscript symbol macro named by the symbol NAME."
110 (and (symbolp name
) (car (lookup-macro-spec name environment
))))
112 (defun script-macro-p (name &optional
(environment *script-macro-env
*))
113 "True if there is a Parenscript macro named by the symbol NAME."
115 (let ((macro-spec (lookup-macro-spec name environment
)))
116 (and macro-spec
(not (car macro-spec
))))))
118 (defun lookup-macro-expansion-function (name &optional
(environment *script-macro-env
*))
119 "Lookup NAME in the given macro expansion environment (which
120 defaults to the current macro environment). Returns the expansion
121 function and the parent macro environment of the macro."
122 (multiple-value-bind (macro-spec parent-env
)
123 (lookup-macro-spec name environment
)
124 (values (cdr macro-spec
) parent-env
)))
126 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
127 (defun make-ps-macro-function (args body
)
128 (let* ((whole-var (when (eql '&whole
(first args
)) (second args
)))
129 (effective-lambda-list (if whole-var
(cddr args
) args
))
130 (form-arg (or whole-var
(gensym "ps-macro-form-arg-")))
131 (body (if (and (cdr body
) (stringp (first body
))) (rest body
) body
))) ;; drop docstring
132 (compile nil
`(lambda (,form-arg
)
133 (destructuring-bind ,effective-lambda-list
137 (defun define-script-macro%
(name args body
&key symbol-macro-p
)
138 (undefine-ps-special-form name
)
139 (setf (get-macro-spec name
*script-macro-toplevel
*)
140 (cons symbol-macro-p
(make-ps-macro-function args body
)))
143 (defmacro defpsmacro
(name args
&body body
)
144 "Define a ParenScript macro, and store it in the toplevel ParenScript
146 `(define-script-macro%
',name
',args
',body
:symbol-macro-p nil
))
148 (defmacro define-script-symbol-macro
(name &body body
)
149 "Define a ParenScript symbol macro, and store it in the toplevel ParenScript
150 macro environment. BODY is a Lisp form that should return a ParenScript form."
151 `(define-script-macro%
',name
() ',body
:symbol-macro-p t
))
153 (defun import-macros-from-lisp (&rest names
)
154 "Import the named Lisp macros into the ParenScript macro
155 environment. When the imported macro is macroexpanded by ParenScript,
156 it is first fully macroexpanded in the Lisp macro environment, and
157 then that expansion is further expanded by ParenScript."
159 (define-script-macro% name
'(&rest args
)
160 (list `(common-lisp:macroexpand
`(,',name
,@args
)))
161 :symbol-macro-p nil
)))
163 (defmacro defmacro
/ps
(name args
&body body
)
164 "Define a Lisp macro and import it into the ParenScript macro environment."
165 `(progn (defmacro ,name
,args
,@body
)
166 (ps:import-macros-from-lisp
',name
)))
168 (defmacro defmacro
+ps
(name args
&body body
)
169 "Define a Lisp macro and a ParenScript macro in their respective
170 macro environments. This function should be used when you want to use
171 the same macro in both Lisp and ParenScript, but the 'macroexpand' of
172 that macro in Lisp makes the Lisp macro unsuitable to be imported into
173 the ParenScript macro environment."
174 `(progn (defmacro ,name
,args
,@body
)
175 (defpsmacro ,name
,args
,@body
)))
177 (defun ps-macroexpand (form)
178 "Recursively macroexpands ParenScript macros and symbol-macros in
179 the given ParenScript form. Returns two values: the expanded form, and
180 whether any expansion was performed on the form or not."
182 (let ((op (car form
))
184 (cond ((equal op
'quote
) (values (if (equalp '(nil) args
) nil form
) ; leave quotes alone, unless it's a quoted nil
186 ((script-macro-p op
) (values (ps-macroexpand (funcall (lookup-macro-expansion-function op
) form
)) t
))
187 (t (values form nil
))))
188 (cond ((script-symbol-macro-p form
) (values (ps-macroexpand (funcall (lookup-macro-expansion-function form
) (list form
))) t
))
189 (t (values form nil
)))))
191 ;;;; compiler interface
192 (defgeneric compile-parenscript-form
(form &key expecting
)
193 (:documentation
"Compiles a ParenScript form to the intermediate
194 ParenScript representation. :expecting determines whether the form is
195 compiled to an :expression (the default), a :statement, or a
198 (defmethod compile-parenscript-form :around
(form &key expecting
)
199 (assert (if expecting
(member expecting
'(:expression
:statement
:symbol
)) t
))
200 (if (eql expecting
:symbol
)
201 (compile-to-symbol form
)
202 (multiple-value-bind (expanded-form expanded-p
)
203 (ps-macroexpand form
)
205 (compile-parenscript-form expanded-form
:expecting expecting
)
206 (call-next-method)))))
208 (defun compile-to-symbol (form)
209 "Compiles the given Parenscript form and guarantees that the
210 resultant symbol has an associated script-package. Raises an error if
211 the form cannot be compiled to a symbol."
212 (let ((exp (compile-parenscript-form form
)))
213 (when (or (eql (first exp
) 'js-variable
)
214 (eql (first exp
) 'script-quote
))
215 (setf exp
(second exp
)))
216 (assert (symbolp exp
) ()
217 "~a is expected to be a symbol, but compiles to ~a (the ParenScript output for ~a alone is \"~a\"). This could be due to ~a being a special form." form exp form
(ps* form
) form
)
220 (defmethod compile-parenscript-form (form &key expecting
)
221 (declare (ignore expecting
))
222 (error "The object ~S cannot be compiled by ParenScript." form
))
224 (defmethod compile-parenscript-form ((form number
) &key expecting
)
225 (declare (ignore expecting
))
228 (defmethod compile-parenscript-form ((form string
) &key expecting
)
229 (declare (ignore expecting
))
232 (defmethod compile-parenscript-form ((form character
) &key expecting
)
233 (declare (ignore expecting
))
234 (compile-parenscript-form (string form
)))
236 (defmethod compile-parenscript-form ((symbol symbol
) &key expecting
)
237 (declare (ignore expecting
))
238 (cond ((ps-special-form-p (list symbol
))
239 (if (ps-literal-p symbol
)
240 (funcall (get-ps-special-form symbol
) :symbol
)
241 (error "Attempting to use Parenscript special form ~a as variable" symbol
)))
242 (t (list 'js-variable symbol
))))
244 (defun compile-function-argument-forms (arg-forms)
245 "Compiles a bunch of Parenscript forms from a funcall form to an effective set of
246 Javascript arguments. The only extra processing this does is makes :keyword arguments
247 into a single options argument via CREATE."
248 (flet ((keyword-arg (arg)
249 "If the given compiled expression is supposed to be a keyword argument, returns
251 (when (and (listp arg
) (eql (first arg
) 'script-quote
)) (second arg
))))
252 (let ((compiled-args (mapcar (lambda (arg) (compile-parenscript-form arg
:expecting
:expression
))
254 (do ((effective-expressions nil
)
255 (expressions-subl compiled-args
))
256 ((not expressions-subl
) (reverse effective-expressions
))
257 (let ((arg-expr (first expressions-subl
)))
258 (if (keyword-arg arg-expr
)
259 (progn (when (oddp (length expressions-subl
))
260 (error "Odd number of keyword arguments: ~A." arg-forms
))
261 (push (list 'js-object
(loop for
(name val
) on expressions-subl by
#'cddr
262 collect
(list name val
)))
263 effective-expressions
)
264 (setf expressions-subl nil
))
265 (progn (push arg-expr effective-expressions
)
266 (setf expressions-subl
(rest expressions-subl
)))))))))
268 (defmethod compile-parenscript-form ((form cons
) &key
(expecting :statement
))
269 (let* ((name (car form
))
271 (cond ((eql name
'quote
)
272 (assert (= 1 (length args
)) () "Wrong number of arguments to quote: ~s" args
)
273 (list 'script-quote
(first args
)))
274 ((ps-special-form-p form
) (apply (get-ps-special-form name
) (cons expecting args
)))
277 (script-convert-op-name (compile-parenscript-form (first form
) :expecting
:symbol
))
278 (mapcar (lambda (form) (compile-parenscript-form form
:expecting
:expression
)) (rest form
))))
279 ((method-call-p form
)
280 (list 'js-method-call
281 (compile-parenscript-form name
:expecting
:symbol
)
282 (compile-parenscript-form (first args
) :expecting
:expression
)
283 (compile-function-argument-forms (rest args
))))
284 ((funcall-form-p form
)
286 (compile-parenscript-form name
:expecting
:expression
)
287 (compile-function-argument-forms args
)))
288 (t (error "Cannot compile ~S to a ParenScript form." form
)))))
290 (defvar *ps-gensym-counter
* 0)
292 (defun ps-gensym (&optional
(prefix "_js"))
293 (make-symbol (format nil
"~A~A" prefix
(incf *ps-gensym-counter
*))))
295 (defmacro with-ps-gensyms
(symbols &body body
)
296 "Evaluate BODY with SYMBOLS bound to unique ParenScript identifiers.
298 Each element of SYMBOLS is either a symbol or a list of (symbol
299 gensym-prefix-string)."
300 `(let* ,(mapcar (lambda (symbol)
301 (destructuring-bind (symbol &optional prefix
)
306 `(,symbol
(ps-gensym ,prefix
))
307 `(,symbol
(ps-gensym ,(symbol-to-js symbol
))))))
311 (defun %check-once-only-vars
(vars)
312 (let ((bad-var (find-if (lambda (x) (or (not (symbolp x
)) (keywordp x
))) vars
)))
314 (error "PS-ONLY-ONCE expected a non-keyword symbol but got ~s" bad-var
))))
316 (defmacro ps-once-only
((&rest vars
) &body body
)
317 (%check-once-only-vars vars
)
318 (let ((gensyms (mapcar (lambda (x) (ps-gensym (string x
))) vars
)))
319 `(let ,(mapcar (lambda (g v
) `(,g
(ps-gensym ,(string v
)))) gensyms vars
)
320 `(let* (,,@(mapcar (lambda (g v
) ``(,,g
,,v
)) gensyms vars
))
321 ,(let ,(mapcar (lambda (g v
) `(,v
,g
)) gensyms vars
)