Commit | Line | Data |
---|---|---|
cc4f1551 RD |
1 | (in-package :parenscript) |
2 | ||
9da682ca | 3 | ;;;; The mechanisms for defining macros & parsing Parenscript. |
a98e58ee RD |
4 | (defgeneric compiler-in-situation-p (comp-env situation) |
5 | (:documentation "Returns true when the compiler is considered 'in' the situation | |
5aa10005 | 6 | given by SITUATION, which is one of :compile-toplevel :execute.") |
a98e58ee RD |
7 | (:method ((comp-env compilation-environment) situation) |
8 | (cond | |
9 | ((eql situation :compile-toplevel) (processing-toplevel-p comp-env)) | |
10 | ((eql situation :execute) (not (processing-toplevel-p comp-env))) | |
11 | (t nil)))) | |
12 | ||
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) | |
18 | )) | |
19 | ||
cc4f1551 | 20 | (eval-when (:compile-toplevel :load-toplevel :execute) |
b506b81b | 21 | (defvar *toplevel-special-forms* (make-hash-table :test #'equal) |
9da682ca RD |
22 | "A hash-table containing functions that implement Parenscript special forms, |
23 | indexed by name (as symbols)") | |
9da682ca RD |
24 | (defun undefine-script-special-form (name) |
25 | "Undefines the special form with the given name (name is a symbol)." | |
06babcf5 | 26 | (remhash (lisp-symbol-to-ps-identifier name :special-form) *toplevel-special-forms*))) |
cc4f1551 | 27 | |
9da682ca | 28 | (defmacro define-script-special-form (name lambda-list &rest body) |
cc4f1551 | 29 | "Define a special form NAME. Arguments are destructured according to |
9da682ca | 30 | LAMBDA-LIST. The resulting Parenscript language types are appended to the |
cc4f1551 | 31 | ongoing javascript compilation." |
b506b81b | 32 | (let ((arglist (gensym "ps-arglist-"))) |
06babcf5 | 33 | `(setf (gethash (lisp-symbol-to-ps-identifier ',name :special-form) *toplevel-special-forms*) |
b506b81b VS |
34 | (lambda (&rest ,arglist) |
35 | (destructuring-bind ,lambda-list | |
36 | ,arglist | |
37 | ,@body))))) | |
9da682ca RD |
38 | |
39 | (defun get-script-special-form (name) | |
40 | "Returns the special form function corresponding to the given name." | |
06babcf5 | 41 | (gethash (lisp-symbol-to-ps-identifier name :special-form) *toplevel-special-forms*)) |
cc4f1551 | 42 | |
9da682ca RD |
43 | ;;; sexp form predicates |
44 | (defun script-special-form-p (form) | |
45 | "Returns T if FORM is a special form and NIL otherwise." | |
cc4f1551 RD |
46 | (and (consp form) |
47 | (symbolp (car form)) | |
171bbab3 | 48 | (get-script-special-form (car form)))) |
cc4f1551 | 49 | |
9da682ca RD |
50 | (defun funcall-form-p (form) |
51 | (and (listp form) | |
5aa10005 | 52 | (not (ps-js::op-form-p form)) |
9da682ca | 53 | (not (script-special-form-p form)))) |
cc4f1551 | 54 | |
9da682ca RD |
55 | (defun method-call-p (form) |
56 | (and (funcall-form-p form) | |
57 | (symbolp (first form)) | |
58 | (eql (char (symbol-name (first form)) 0) #\.))) | |
cc4f1551 | 59 | |
9da682ca | 60 | ;;; macro expansion |
cc4f1551 RD |
61 | (eval-when (:compile-toplevel :load-toplevel :execute) |
62 | (defun make-macro-env-dictionary () | |
9da682ca | 63 | "Creates a standard macro dictionary." |
06babcf5 | 64 | (make-hash-table :test #'equal)) |
9da682ca | 65 | (defvar *script-macro-toplevel* (make-macro-env-dictionary) |
72332f2a VS |
66 | "Toplevel macro environment dictionary. Key is the symbol of the |
67 | macro, value is (symbol-macro-p . expansion-function).") | |
06babcf5 | 68 | (defvar *script-macro-env* (list *script-macro-toplevel*) |
171bbab3 | 69 | "Current macro environment.") |
72332f2a VS |
70 | |
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.") | |
171bbab3 | 76 | |
06babcf5 VS |
77 | (defun get-macro-spec (name env-dict) |
78 | "Retrieves the macro spec of the given name with the given environment dictionary. | |
72332f2a | 79 | SPEC is of the form (symbol-macro-p . expansion-function)." |
06babcf5 VS |
80 | (gethash (lisp-symbol-to-ps-identifier name :macro) env-dict)) |
81 | (defsetf get-macro-spec (name env-dict) | |
82 | (spec) | |
83 | `(setf (gethash (lisp-symbol-to-ps-identifier ,name :macro) ,env-dict) ,spec))) | |
9da682ca RD |
84 | |
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 | |
905f534e | 87 | macro spec is of the form (symbol-macro-p . function). Returns two values: |
9da682ca | 88 | the SPEC and the parent macro environment. |
cc4f1551 | 89 | |
9da682ca | 90 | NAME must be a symbol." |
cc4f1551 RD |
91 | (when (symbolp name) |
92 | (do ((env environment (cdr env))) | |
93 | ((null env) nil) | |
94 | (let ((val (get-macro-spec name (car env)))) | |
95 | (when val | |
96 | (return-from lookup-macro-spec | |
97 | (values val (or (cdr env) | |
9da682ca | 98 | (list *script-macro-toplevel*))))))))) |
cc4f1551 | 99 | |
9da682ca RD |
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." | |
cc4f1551 RD |
102 | (and (symbolp name) (car (lookup-macro-spec name environment)))) |
103 | ||
9da682ca RD |
104 | (defun script-macro-p (name &optional (environment *script-macro-env*)) |
105 | "True if there is a Parenscript macro named by the symbol NAME." | |
106 | (and (symbolp name) | |
107 | (let ((macro-spec (lookup-macro-spec name environment))) | |
108 | (and macro-spec (not (car macro-spec)))))) | |
cc4f1551 | 109 | |
9da682ca | 110 | (defun lookup-macro-expansion-function (name &optional (environment *script-macro-env*)) |
cc4f1551 RD |
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))) | |
117 | ||
d9fc64c9 | 118 | (defun define-script-macro% (name args body &key symbol-macro-p) |
cc4f1551 | 119 | (let ((lambda-list (gensym "ps-lambda-list-")) |
0b37e317 | 120 | (body (if (and (cdr body) (stringp (first body))) (rest body) body))) ;; drop docstring |
9da682ca | 121 | (undefine-script-special-form name) |
d9fc64c9 VS |
122 | (setf (get-macro-spec name *script-macro-toplevel*) |
123 | (cons symbol-macro-p (compile nil `(lambda (&rest ,lambda-list) | |
124 | (destructuring-bind ,args | |
125 | ,lambda-list | |
126 | ,@body))))) | |
127 | nil)) | |
128 | ||
129 | (defmacro defscriptmacro (name args &body body) | |
130 | "Define a ParenScript macro, and store it in the toplevel ParenScript | |
131 | macro environment." | |
132 | (define-script-macro% name args body :symbol-macro-p nil)) | |
cc4f1551 | 133 | |
46f794a4 | 134 | (defmacro define-script-symbol-macro (name &body body) |
b5369cb1 | 135 | "Define a ParenScript symbol macro, and store it in the toplevel ParenScript |
46f794a4 | 136 | macro environment. BODY is a Lisp form that should return a ParenScript form." |
d9fc64c9 | 137 | (define-script-macro% name () body :symbol-macro-p t)) |
b5369cb1 | 138 | |
7590646c VS |
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." | |
144 | (dolist (name names) | |
d9fc64c9 | 145 | (define-script-macro% name '(&rest args) (list `(common-lisp:macroexpand `(,',name ,@args))) :symbol-macro-p nil))) |
7590646c | 146 | |
f016e033 | 147 | (defmacro defmacro/ps (name args &body body) |
7590646c VS |
148 | "Define a Lisp macro and import it into the ParenScript macro environment." |
149 | `(progn (defmacro ,name ,args ,@body) | |
f016e033 | 150 | (ps:import-macros-from-lisp ',name))) |
7590646c | 151 | |
f016e033 | 152 | (defmacro defmacro+ps (name args &body body) |
7590646c VS |
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))) | |
160 | ||
161 | (defmacro defpsmacro (&rest args) | |
162 | `(defscriptmacro ,@args)) | |
9da682ca RD |
163 | |
164 | (defun expand-script-form (expr) | |
46f794a4 RD |
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." | |
cc4f1551 RD |
168 | (if (consp expr) |
169 | (let ((op (car expr)) | |
170 | (args (cdr expr))) | |
46f794a4 RD |
171 | (cond ((equal op 'quote) |
172 | (values | |
173 | (if (equalp '(nil) args) nil expr) ;; leave quotes alone, unless it's a quoted nil | |
174 | nil)) | |
9da682ca RD |
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) | |
46f794a4 RD |
178 | (values |
179 | (expand-script-form (let ((*script-macro-env* macro-env)) | |
180 | (apply expansion-function args))) | |
181 | t))) | |
d9fc64c9 VS |
182 | ((script-special-form-p expr) |
183 | (values expr nil)) | |
46f794a4 | 184 | (t (values expr nil)))) |
d9fc64c9 | 185 | (cond ((script-symbol-macro-p expr) |
9da682ca RD |
186 | ;; recursively expand symbol macros in parent env. |
187 | (multiple-value-bind (expansion-function macro-env) | |
188 | (lookup-macro-expansion-function expr) | |
46f794a4 RD |
189 | (values |
190 | (expand-script-form (let ((*script-macro-env* macro-env)) | |
191 | (funcall expansion-function))) | |
192 | t))) | |
9da682ca | 193 | ;; leave anything else alone |
46f794a4 | 194 | (t (values expr nil))))) |
cc4f1551 | 195 | |
a98e58ee RD |
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" | |
199 | (let* ((rest args) | |
200 | (form-language | |
201 | (when (not (listp (first rest))) | |
202 | (setf rest (rest args)) | |
203 | (first args))) | |
204 | (situations (first rest)) | |
205 | (body (rest 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) | |
209 | (setf form-language | |
210 | (cond | |
211 | ((find :compile-toplevel situations) :lisp) | |
212 | ((find :execute situations) :parenscript)))) | |
213 | (values form-language situations body))) | |
214 | ||
cc4f1551 | 215 | ;;;; compiler interface ;;;; |
46f794a4 | 216 | (defgeneric compile-parenscript-form (compilation-environment form) |
a98e58ee RD |
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. | |
220 | ||
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")) | |
9da682ca | 225 | |
46f794a4 RD |
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.")) | |
230 | ||
231 | (defmethod compile-toplevel-parenscript-form ((comp-env compilation-environment) form) | |
232 | (cond | |
233 | ((not (listp form)) form) | |
234 | ;; process each clause of a progn as a toplevel form | |
235 | ((eql 'progn (car form)) | |
236 | `(progn | |
237 | ,@(mapcar #'(lambda (subform) | |
238 | (compile-parenscript-form comp-env subform)) | |
239 | (rest form)))) | |
240 | ;; TODO process macrolets, symbol-macrolets, and file inclusions | |
241 | ||
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)) | |
247 | (cond | |
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 | |
255 | comp-env | |
256 | `(progn | |
257 | ,(funcall function) | |
258 | ,@(when other-situations | |
259 | (list `(eval-when ,other-situations ,@body))))))))) | |
260 | ;; if :compile-toplevel is not in the situation list, return the form | |
261 | (t form)))) | |
262 | (t form))) | |
263 | ||
264 | ||
265 | (defmethod compile-parenscript-form :around ((comp-env compilation-environment) form) | |
266 | (multiple-value-bind (expanded-form expanded-p) | |
267 | (expand-script-form form) | |
268 | (cond | |
269 | (expanded-p | |
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))))) | |
274 | ||
275 | (defmethod compile-parenscript-form ((comp-env compilation-environment) (form string)) | |
276 | (make-instance 'ps-js::string-literal :value form)) | |
277 | ||
278 | (defmethod compile-parenscript-form ((comp-env compilation-environment) (form character)) | |
279 | (compile-parenscript-form comp-env (string form))) | |
280 | ||
281 | (defmethod compile-parenscript-form ((comp-env compilation-environment) (form number)) | |
282 | (make-instance 'ps-js::number-literal :value form)) | |
283 | ||
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))) | |
287 | (cond | |
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))))) | |
293 | ||
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 | |
300 | the keyword for it." | |
301 | (when (typep arg 'script-quote) (ps-js::value arg)))) | |
302 | (let ((expressions (mapcar #'compile-to-expression forms))) | |
303 | ||
304 | (do ((effective-expressions nil) | |
305 | (expressions-subl expressions)) | |
306 | ||
307 | ((not expressions-subl) | |
308 | (nreverse effective-expressions)) | |
309 | ||
310 | (let ((arg-expr (first expressions-subl))) | |
311 | (if (keyword-arg arg-expr) | |
312 | (progn | |
313 | (when (oddp (length expressions-subl)) | |
314 | (error "Odd number of keyword arguments.")) | |
315 | (push | |
316 | (make-instance 'ps-js::js-object | |
317 | :slots | |
318 | (loop for (name val) on expressions-subl by #'cddr | |
319 | collect (list name val))) | |
320 | effective-expressions) | |
321 | (setf expressions-subl nil)) | |
322 | (progn | |
323 | (push arg-expr effective-expressions) | |
324 | (setf expressions-subl (rest expressions-subl))))))))) | |
325 | ||
326 | (defmethod compile-parenscript-form ((comp-env compilation-environment) (form cons)) | |
327 | (let* ((name (car form)) | |
328 | (args (cdr form)) | |
d9fc64c9 | 329 | (script-form (when (symbolp name) (get-script-special-form name)))) |
46f794a4 RD |
330 | (cond |
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))))) | |
cc4f1551 | 347 | |
9da682ca RD |
348 | (defun compile-script-form (form &key (comp-env *compilation-environment*)) |
349 | "Compiles a Parenscript form to an AST node." | |
727a0288 | 350 | (compile-parenscript-form comp-env form)) |
9da682ca RD |
351 | |
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))) | |
5e0e55be VS |
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)) | |
cc4f1551 RD |
358 | res)) |
359 | ||
9da682ca | 360 | (defun compile-to-symbol (form) |
5aa10005 RD |
361 | "Compiles the given Parenscript form and guarantees a symbolic result. This |
362 | also guarantees that the symbol has an associated script-package." | |
9da682ca | 363 | (let ((res (compile-script-form form))) |
5aa10005 RD |
364 | (when (typep res 'ps-js::js-variable) |
365 | (setf res (ps-js::value res))) | |
bbea4c83 RD |
366 | (when (typep res 'ps-js::script-quote) |
367 | (setf res (ps-js::value res))) | |
30135005 | 368 | (assert (symbolp res) () |
905f534e | 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) |
8723dc34 VS |
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") | |
375 | res)))) | |
cc4f1551 RD |
376 | res)) |
377 | ||
9da682ca RD |
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))) | |
5aa10005 | 381 | (assert (typep res 'ps-js::statement)) |
cc4f1551 RD |
382 | res)) |
383 | ||
5aa10005 | 384 | (defun compile-to-block (form &key (indent "")) |
9da682ca RD |
385 | "Compiles the given Parenscript form and guarantees the result is of type SCRIPT-BODY" |
386 | (let ((res (compile-to-statement form))) | |
5aa10005 RD |
387 | (if (typep res 'ps-js::js-block) |
388 | (progn (setf (ps-js::block-indent res) indent) | |
cc4f1551 | 389 | res) |
5aa10005 | 390 | (make-instance 'ps-js::js-block |
cc4f1551 | 391 | :indent indent |
9da682ca | 392 | :statements (list res))))) |