1 (in-package :parenscript
)
3 ;;;; The mechanisms for defining macros & parsing Parenscript.
4 (defgeneric compiler-in-situation-p
(comp-env situation
)
5 (:documentation
"Returns true when the compiler is considered 'in' the situation
6 given by SITUATION, which is one of :compile-toplevel :execute.")
7 (:method
((comp-env compilation-environment
) situation
)
9 ((eql situation
:compile-toplevel
) (processing-toplevel-p comp-env
))
10 ((eql situation
:execute
) (not (processing-toplevel-p comp-env
)))
13 (defgeneric processing-toplevel-p
(comp-env)
14 (:documentation
"T if we are compiling TOPLEVEL forms, as in
15 http://www.lispworks.com/documentation/HyperSpec/Body/03_bca.htm")
16 (:method
((comp-env compilation-environment
))
17 (comp-env-compiling-toplevel-p comp-env
)
20 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
21 (defvar *toplevel-special-forms
* (make-hash-table :test
#'equal
)
22 "A hash-table containing functions that implement Parenscript special forms,
23 indexed by name (as symbols)")
24 (defun undefine-script-special-form (name)
25 "Undefines the special form with the given name (name is a symbol)."
26 (remhash (lisp-symbol-to-ps-identifier name
:special-form
) *toplevel-special-forms
*)))
28 (defmacro define-script-special-form
(name lambda-list
&rest body
)
29 "Define a special form NAME. Arguments are destructured according to
30 LAMBDA-LIST. The resulting Parenscript language types are appended to the
31 ongoing javascript compilation."
32 (let ((arglist (gensym "ps-arglist-")))
33 `(setf (gethash (lisp-symbol-to-ps-identifier ',name
:special-form
) *toplevel-special-forms
*)
34 (lambda (&rest
,arglist
)
35 (destructuring-bind ,lambda-list
39 (defun get-script-special-form (name)
40 "Returns the special form function corresponding to the given name."
41 (gethash (lisp-symbol-to-ps-identifier name
:special-form
) *toplevel-special-forms
*))
43 ;;; sexp form predicates
44 (defun script-special-form-p (form)
45 "Returns T if FORM is a special form and NIL otherwise."
48 (get-script-special-form (car form
))))
50 (defun funcall-form-p (form)
52 (not (ps-js::op-form-p form
))
53 (not (script-special-form-p form
))))
55 (defun method-call-p (form)
56 (and (funcall-form-p form
)
57 (symbolp (first form
))
58 (eql (char (symbol-name (first form
)) 0) #\.
)))
61 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
62 (defun make-macro-env-dictionary ()
63 "Creates a standard macro dictionary."
64 (make-hash-table :test
#'equal
))
65 (defvar *script-macro-toplevel
* (make-macro-env-dictionary)
66 "Toplevel macro environment dictionary. Key is the symbol of the
67 macro, value is (symbol-macro-p . expansion-function).")
68 (defvar *script-macro-env
* (list *script-macro-toplevel
*)
69 "Current macro environment.")
71 (defvar *script-setf-expanders
* (make-macro-env-dictionary)
72 "Setf expander dictionary. Key is the symbol of the access
73 function of the place, value is an expansion function that takes the
74 arguments of the access functions as a first value and the form to be
75 stored as the second value.")
77 (defun get-macro-spec (name env-dict
)
78 "Retrieves the macro spec of the given name with the given environment dictionary.
79 SPEC is of the form (symbol-macro-p . expansion-function)."
80 (gethash (lisp-symbol-to-ps-identifier name
:macro
) env-dict
))
81 (defsetf get-macro-spec
(name env-dict
)
83 `(setf (gethash (lisp-symbol-to-ps-identifier ,name
:macro
) ,env-dict
) ,spec
)))
85 (defun lookup-macro-spec (name &optional
(environment *script-macro-env
*))
86 "Looks up the macro spec associated with NAME in the given environment. A
87 macro spec is of the form (symbol-macro-p . function). Returns two values:
88 the SPEC and the parent macro environment.
90 NAME must be a symbol."
92 (do ((env environment
(cdr env
)))
94 (let ((val (get-macro-spec name
(car env
))))
96 (return-from lookup-macro-spec
97 (values val
(or (cdr env
)
98 (list *script-macro-toplevel
*)))))))))
100 (defun script-symbol-macro-p (name &optional
(environment *script-macro-env
*))
101 "True if there is a Parenscript symbol macro named by the symbol NAME."
102 (and (symbolp name
) (car (lookup-macro-spec name environment
))))
104 (defun script-macro-p (name &optional
(environment *script-macro-env
*))
105 "True if there is a Parenscript macro named by the symbol NAME."
107 (let ((macro-spec (lookup-macro-spec name environment
)))
108 (and macro-spec
(not (car macro-spec
))))))
110 (defun lookup-macro-expansion-function (name &optional
(environment *script-macro-env
*))
111 "Lookup NAME in the given macro expansion environment (which
112 defaults to the current macro environment). Returns the expansion
113 function and the parent macro environment of the macro."
114 (multiple-value-bind (macro-spec parent-env
)
115 (lookup-macro-spec name environment
)
116 (values (cdr macro-spec
) parent-env
)))
118 (defun define-script-macro%
(name args body
&key symbol-macro-p
)
119 (let ((lambda-list (gensym "ps-lambda-list-"))
120 (body (if (and (cdr body
) (stringp (first body
))) (rest body
) body
))) ;; drop docstring
121 (undefine-script-special-form name
)
122 (setf (get-macro-spec name
*script-macro-toplevel
*)
123 (cons symbol-macro-p
(compile nil
`(lambda (&rest
,lambda-list
)
124 (destructuring-bind ,args
129 (defmacro defscriptmacro
(name args
&body body
)
130 "Define a ParenScript macro, and store it in the toplevel ParenScript
132 (define-script-macro% name args body
:symbol-macro-p nil
))
134 (defmacro define-script-symbol-macro
(name &body body
)
135 "Define a ParenScript symbol macro, and store it in the toplevel ParenScript
136 macro environment. BODY is a Lisp form that should return a ParenScript form."
137 (define-script-macro% name
() body
:symbol-macro-p t
))
139 (defun import-macros-from-lisp (&rest names
)
140 "Import the named Lisp macros into the ParenScript macro
141 environment. When the imported macro is macroexpanded by ParenScript,
142 it is first fully macroexpanded in the Lisp macro environment, and
143 then that expansion is further expanded by ParenScript."
145 (define-script-macro% name
'(&rest args
) (list `(common-lisp:macroexpand
`(,',name
,@args
))) :symbol-macro-p nil
)))
147 (defmacro defmacro
/ps
(name args
&body body
)
148 "Define a Lisp macro and import it into the ParenScript macro environment."
149 `(progn (defmacro ,name
,args
,@body
)
150 (ps:import-macros-from-lisp
',name
)))
152 (defmacro defmacro
+ps
(name args
&body body
)
153 "Define a Lisp macro and a ParenScript macro in their respective
154 macro environments. This function should be used when you want to use
155 the same macro in both Lisp and ParenScript, but the 'macroexpand' of
156 that macro in Lisp makes the Lisp macro unsuitable to be imported into
157 the ParenScript macro environment."
158 `(progn (defmacro ,name
,args
,@body
)
159 (defscriptmacro ,name
,args
,@body
)))
161 (defmacro defpsmacro
(&rest args
)
162 `(defscriptmacro ,@args
))
164 (defun expand-script-form (expr)
165 "Expands a Parenscript form until it reaches a special form. Returns 2 values:
166 1. the expanded form.
167 2. whether the form was expanded."
169 (let ((op (car expr
))
171 (cond ((equal op
'quote
)
173 (if (equalp '(nil) args
) nil expr
) ;; leave quotes alone, unless it's a quoted nil
175 ((script-macro-p op
) ;; recursively expand parenscript macros in parent env.
176 (multiple-value-bind (expansion-function macro-env
)
177 (lookup-macro-expansion-function op
)
179 (expand-script-form (let ((*script-macro-env
* macro-env
))
180 (apply expansion-function args
)))
182 ((script-special-form-p expr
)
184 (t (values expr nil
))))
185 (cond ((script-symbol-macro-p expr
)
186 ;; recursively expand symbol macros in parent env.
187 (multiple-value-bind (expansion-function macro-env
)
188 (lookup-macro-expansion-function expr
)
190 (expand-script-form (let ((*script-macro-env
* macro-env
))
191 (funcall expansion-function
)))
193 ;; leave anything else alone
194 (t (values expr nil
)))))
196 (defun process-eval-when-args (args)
197 "(eval-when form-language? (situation*) form*) - returns 3 values:
198 form-language, a list of situations, and a list of body forms"
201 (when (not (listp (first rest
)))
202 (setf rest
(rest args
))
204 (situations (first rest
))
206 (when (and (find :compile-toplevel situations
) (find :execute situations
))
207 (error "Cannot use EVAL-WHEN to execute COMPILE-TOPLEVEL and EXECUTE code simultaneously."))
208 (when (null form-language
)
211 ((find :compile-toplevel situations
) :lisp
)
212 ((find :execute situations
) :parenscript
))))
213 (values form-language situations body
)))
215 ;;;; compiler interface ;;;;
216 (defgeneric compile-parenscript-form
(compilation-environment form
)
217 (:documentation
"Compiles FORM, which is a ParenScript form.
218 If toplevel-p is NIL, the result is a compilation object (the AST root).
219 Subsequently TRANSLATE-AST can be called to convert the result to Javascript.
221 If the compiler is in the COMPILE-TOPLEVEL stage, then the result will
222 be a Parenscript form (after it has been processed according to semantics
223 like those of Lisp's COMPILE-FILE). See
224 http://www.lispworks.com/documentation/HyperSpec/Body/03_bca.htm"))
226 (defgeneric compile-toplevel-parenscript-form
(comp-env form
)
227 (:documentation
"Compiles a parenscript form in the given compilation environment
228 when the environment is in the :compile-toplevel situation. Returns a form to be
229 compiled in place of the original form upon exiting the :compile-toplevel situation."))
231 (defmethod compile-toplevel-parenscript-form ((comp-env compilation-environment
) form
)
233 ((not (listp form
)) form
)
234 ;; process each clause of a progn as a toplevel form
235 ((eql 'progn
(car form
))
237 ,@(mapcar #'(lambda (subform)
238 (compile-parenscript-form comp-env subform
))
240 ;; TODO process macrolets, symbol-macrolets, and file inclusions
242 ;; process eval-when. evaluates in :COMPILE-TOPLEVEL situation and returns
243 ;; the resultant form. for :EXECUTE situation it returns
244 ((eql 'eval-when
(car form
))
245 (multiple-value-bind (body-language situations body
)
246 (process-eval-when-args (rest form
))
248 ((find :compile-toplevel situations
)
249 (when (eql body-language
:lisp
)
250 (let ((other-situations (remove :compile-toplevel situations
)))
251 (multiple-value-bind (function warnings-p failure-p
)
252 (compile nil
`(lambda () ,@body
))
253 (declare (ignore warnings-p
) (ignore failure-p
))
254 (compile-parenscript-form
258 ,@(when other-situations
259 (list `(eval-when ,other-situations
,@body
)))))))))
260 ;; if :compile-toplevel is not in the situation list, return the form
265 (defmethod compile-parenscript-form :around
((comp-env compilation-environment
) form
)
266 (multiple-value-bind (expanded-form expanded-p
)
267 (expand-script-form form
)
270 (compile-parenscript-form comp-env expanded-form
))
271 ((comp-env-compiling-toplevel-p comp-env
)
272 (compile-toplevel-parenscript-form comp-env form
))
273 (t (call-next-method)))))
275 (defmethod compile-parenscript-form ((comp-env compilation-environment
) (form string
))
276 (make-instance 'ps-js
::string-literal
:value form
))
278 (defmethod compile-parenscript-form ((comp-env compilation-environment
) (form character
))
279 (compile-parenscript-form comp-env
(string form
)))
281 (defmethod compile-parenscript-form ((comp-env compilation-environment
) (form number
))
282 (make-instance 'ps-js
::number-literal
:value form
))
284 (defmethod compile-parenscript-form ((comp-env compilation-environment
) (form symbol
))
285 ;; is this the correct behavior?
286 (let ((c-macro (get-script-special-form form
)))
288 (c-macro (funcall c-macro
))
289 ;; the following emulates the lisp behavior that a keyword is bound to itself
290 ;; see http://clhs.lisp.se/Body/t_kwd.htm
291 ((keywordp form
) (compile-parenscript-form comp-env
`(quote ,form
)))
292 (t (make-instance 'ps-js
::js-variable
:value form
)))))
294 (defun compile-function-argument-forms (forms)
295 "Compiles a bunch of Parenscript forms from a funcall form to an effective set of
296 Javascript arguments. The only extra processing this does is makes :keyword arguments
297 into a single options argument via CREATE."
298 (flet ((keyword-arg (arg)
299 "If the given compiled expression is supposed to be a keyword argument, returns
301 (when (typep arg
'script-quote
) (ps-js::value arg
))))
302 (let ((expressions (mapcar #'compile-to-expression forms
)))
304 (do ((effective-expressions nil
)
305 (expressions-subl expressions
))
307 ((not expressions-subl
)
308 (nreverse effective-expressions
))
310 (let ((arg-expr (first expressions-subl
)))
311 (if (keyword-arg arg-expr
)
313 (when (oddp (length expressions-subl
))
314 (error "Odd number of keyword arguments."))
316 (make-instance 'ps-js
::js-object
318 (loop for
(name val
) on expressions-subl by
#'cddr
319 collect
(list name val
)))
320 effective-expressions
)
321 (setf expressions-subl nil
))
323 (push arg-expr effective-expressions
)
324 (setf expressions-subl
(rest expressions-subl
)))))))))
326 (defmethod compile-parenscript-form ((comp-env compilation-environment
) (form cons
))
327 (let* ((name (car form
))
329 (script-form (when (symbolp name
) (get-script-special-form name
))))
331 ((eql name
'quote
) (make-instance 'script-quote
:value
(first args
)))
332 (script-form (apply script-form args
))
333 ((ps-js::op-form-p form
)
334 (make-instance 'ps-js
::op-form
335 :operator
(ps-js::script-convert-op-name
(compile-to-symbol (first form
)))
336 :args
(mapcar #'compile-to-expression
(rest form
))))
337 ((method-call-p form
)
338 (make-instance 'ps-js
::method-call
339 :method
(compile-to-symbol name
)
340 :object
(compile-to-expression (first args
))
341 :args
(compile-function-argument-forms (rest args
))))
342 ((funcall-form-p form
)
343 (make-instance 'ps-js
::function-call
344 :function
(compile-to-expression name
)
345 :args
(compile-function-argument-forms args
)))
346 (t (error "Unknown form ~S" form
)))))
348 (defun compile-script-form (form &key
(comp-env *compilation-environment
*))
349 "Compiles a Parenscript form to an AST node."
350 (compile-parenscript-form comp-env form
))
352 (defun compile-to-expression (form)
353 "Compiles the given Parenscript form and guarantees the result is an expression."
354 (let ((res (compile-script-form form
)))
355 (assert (typep res
'ps-js
::expression
) ()
356 "Error: ~s was expected to compile to a ParenScript expression, but instead compiled to ~s, which has type ~s"
357 form res
(type-of res
))
360 (defun compile-to-symbol (form)
361 "Compiles the given Parenscript form and guarantees a symbolic result. This
362 also guarantees that the symbol has an associated script-package."
363 (let ((res (compile-script-form form
)))
364 (when (typep res
'ps-js
::js-variable
)
365 (setf res
(ps-js::value res
)))
366 (when (typep res
'ps-js
::script-quote
)
367 (setf res
(ps-js::value res
)))
368 (assert (symbolp res
) ()
369 "~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 res form
(ps::ps
* form
) form
)
370 (unless (symbol-script-package res
)
371 (when *warn-ps-package
*
372 (warn 'simple-style-warning
373 :format-control
"The symbol ~A::~A has no associated script package."
374 :format-arguments
(list (if (symbol-package res
) (package-name (symbol-package res
)) "ANONYMOUS-PACKAGE")
378 (defun compile-to-statement (form)
379 "Compiles the given Parenscript form and guarantees the result is a statement."
380 (let ((res (compile-script-form form
)))
381 (assert (typep res
'ps-js
::statement
))
384 (defun compile-to-block (form &key
(indent ""))
385 "Compiles the given Parenscript form and guarantees the result is of type SCRIPT-BODY"
386 (let ((res (compile-to-statement form
)))
387 (if (typep res
'ps-js
::js-block
)
388 (progn (setf (ps-js::block-indent res
) indent
)
390 (make-instance 'ps-js
::js-block
392 :statements
(list res
)))))