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 | ||
e22d923b RD |
118 | (eval-when (:compile-toplevel :load-toplevel :execute) |
119 | (defun define-script-macro% (name args body &key symbol-macro-p) | |
120 | (format t "Defining script macro ~A~%" name) | |
121 | (let ((lambda-list (gensym "ps-lambda-list-")) | |
122 | (body (if (and (cdr body) (stringp (first body))) (rest body) body))) ;; drop docstring | |
123 | (undefine-script-special-form name) | |
124 | (setf (get-macro-spec name *script-macro-toplevel*) | |
125 | (cons symbol-macro-p (compile nil `(lambda (&rest ,lambda-list) | |
126 | (destructuring-bind ,args | |
127 | ,lambda-list | |
128 | ,@body))))) | |
129 | nil))) | |
d9fc64c9 VS |
130 | |
131 | (defmacro defscriptmacro (name args &body body) | |
132 | "Define a ParenScript macro, and store it in the toplevel ParenScript | |
133 | macro environment." | |
e22d923b | 134 | `(define-script-macro% ',name ',args ',body :symbol-macro-p nil)) |
cc4f1551 | 135 | |
46f794a4 | 136 | (defmacro define-script-symbol-macro (name &body body) |
b5369cb1 | 137 | "Define a ParenScript symbol macro, and store it in the toplevel ParenScript |
46f794a4 | 138 | macro environment. BODY is a Lisp form that should return a ParenScript form." |
e22d923b | 139 | `(define-script-macro% ',name () ',body :symbol-macro-p t)) |
b5369cb1 | 140 | |
7590646c VS |
141 | (defun import-macros-from-lisp (&rest names) |
142 | "Import the named Lisp macros into the ParenScript macro | |
143 | environment. When the imported macro is macroexpanded by ParenScript, | |
144 | it is first fully macroexpanded in the Lisp macro environment, and | |
145 | then that expansion is further expanded by ParenScript." | |
146 | (dolist (name names) | |
e22d923b RD |
147 | (define-script-macro% name '(&rest args) |
148 | (list `(common-lisp:macroexpand `(,',name ,@args))) | |
149 | :symbol-macro-p nil))) | |
7590646c | 150 | |
f016e033 | 151 | (defmacro defmacro/ps (name args &body body) |
7590646c VS |
152 | "Define a Lisp macro and import it into the ParenScript macro environment." |
153 | `(progn (defmacro ,name ,args ,@body) | |
f016e033 | 154 | (ps:import-macros-from-lisp ',name))) |
7590646c | 155 | |
f016e033 | 156 | (defmacro defmacro+ps (name args &body body) |
7590646c VS |
157 | "Define a Lisp macro and a ParenScript macro in their respective |
158 | macro environments. This function should be used when you want to use | |
159 | the same macro in both Lisp and ParenScript, but the 'macroexpand' of | |
160 | that macro in Lisp makes the Lisp macro unsuitable to be imported into | |
161 | the ParenScript macro environment." | |
162 | `(progn (defmacro ,name ,args ,@body) | |
163 | (defscriptmacro ,name ,args ,@body))) | |
164 | ||
165 | (defmacro defpsmacro (&rest args) | |
166 | `(defscriptmacro ,@args)) | |
9da682ca RD |
167 | |
168 | (defun expand-script-form (expr) | |
46f794a4 RD |
169 | "Expands a Parenscript form until it reaches a special form. Returns 2 values: |
170 | 1. the expanded form. | |
171 | 2. whether the form was expanded." | |
cc4f1551 RD |
172 | (if (consp expr) |
173 | (let ((op (car expr)) | |
174 | (args (cdr expr))) | |
46f794a4 RD |
175 | (cond ((equal op 'quote) |
176 | (values | |
177 | (if (equalp '(nil) args) nil expr) ;; leave quotes alone, unless it's a quoted nil | |
178 | nil)) | |
9da682ca RD |
179 | ((script-macro-p op) ;; recursively expand parenscript macros in parent env. |
180 | (multiple-value-bind (expansion-function macro-env) | |
181 | (lookup-macro-expansion-function op) | |
46f794a4 RD |
182 | (values |
183 | (expand-script-form (let ((*script-macro-env* macro-env)) | |
184 | (apply expansion-function args))) | |
185 | t))) | |
d9fc64c9 VS |
186 | ((script-special-form-p expr) |
187 | (values expr nil)) | |
46f794a4 | 188 | (t (values expr nil)))) |
d9fc64c9 | 189 | (cond ((script-symbol-macro-p expr) |
9da682ca RD |
190 | ;; recursively expand symbol macros in parent env. |
191 | (multiple-value-bind (expansion-function macro-env) | |
192 | (lookup-macro-expansion-function expr) | |
46f794a4 RD |
193 | (values |
194 | (expand-script-form (let ((*script-macro-env* macro-env)) | |
195 | (funcall expansion-function))) | |
196 | t))) | |
9da682ca | 197 | ;; leave anything else alone |
46f794a4 | 198 | (t (values expr nil))))) |
cc4f1551 | 199 | |
a98e58ee RD |
200 | (defun process-eval-when-args (args) |
201 | "(eval-when form-language? (situation*) form*) - returns 3 values: | |
202 | form-language, a list of situations, and a list of body forms" | |
203 | (let* ((rest args) | |
204 | (form-language | |
205 | (when (not (listp (first rest))) | |
206 | (setf rest (rest args)) | |
207 | (first args))) | |
208 | (situations (first rest)) | |
209 | (body (rest rest))) | |
210 | (when (and (find :compile-toplevel situations) (find :execute situations)) | |
211 | (error "Cannot use EVAL-WHEN to execute COMPILE-TOPLEVEL and EXECUTE code simultaneously.")) | |
212 | (when (null form-language) | |
213 | (setf form-language | |
214 | (cond | |
215 | ((find :compile-toplevel situations) :lisp) | |
216 | ((find :execute situations) :parenscript)))) | |
217 | (values form-language situations body))) | |
218 | ||
cc4f1551 | 219 | ;;;; compiler interface ;;;; |
46f794a4 | 220 | (defgeneric compile-parenscript-form (compilation-environment form) |
a98e58ee RD |
221 | (:documentation "Compiles FORM, which is a ParenScript form. |
222 | If toplevel-p is NIL, the result is a compilation object (the AST root). | |
223 | Subsequently TRANSLATE-AST can be called to convert the result to Javascript. | |
224 | ||
225 | If the compiler is in the COMPILE-TOPLEVEL stage, then the result will | |
226 | be a Parenscript form (after it has been processed according to semantics | |
227 | like those of Lisp's COMPILE-FILE). See | |
228 | http://www.lispworks.com/documentation/HyperSpec/Body/03_bca.htm")) | |
9da682ca | 229 | |
46f794a4 RD |
230 | (defgeneric compile-toplevel-parenscript-form (comp-env form) |
231 | (:documentation "Compiles a parenscript form in the given compilation environment | |
232 | when the environment is in the :compile-toplevel situation. Returns a form to be | |
233 | compiled in place of the original form upon exiting the :compile-toplevel situation.")) | |
234 | ||
235 | (defmethod compile-toplevel-parenscript-form ((comp-env compilation-environment) form) | |
236 | (cond | |
237 | ((not (listp form)) form) | |
238 | ;; process each clause of a progn as a toplevel form | |
239 | ((eql 'progn (car form)) | |
240 | `(progn | |
241 | ,@(mapcar #'(lambda (subform) | |
242 | (compile-parenscript-form comp-env subform)) | |
243 | (rest form)))) | |
244 | ;; TODO process macrolets, symbol-macrolets, and file inclusions | |
245 | ||
246 | ;; process eval-when. evaluates in :COMPILE-TOPLEVEL situation and returns | |
247 | ;; the resultant form. for :EXECUTE situation it returns | |
248 | ((eql 'eval-when (car form)) | |
249 | (multiple-value-bind (body-language situations body) | |
250 | (process-eval-when-args (rest form)) | |
251 | (cond | |
252 | ((find :compile-toplevel situations) | |
253 | (when (eql body-language :lisp) | |
254 | (let ((other-situations (remove :compile-toplevel situations))) | |
255 | (multiple-value-bind (function warnings-p failure-p) | |
256 | (compile nil `(lambda () ,@body)) | |
257 | (declare (ignore warnings-p) (ignore failure-p)) | |
258 | (compile-parenscript-form | |
259 | comp-env | |
260 | `(progn | |
261 | ,(funcall function) | |
262 | ,@(when other-situations | |
263 | (list `(eval-when ,other-situations ,@body))))))))) | |
264 | ;; if :compile-toplevel is not in the situation list, return the form | |
265 | (t form)))) | |
266 | (t form))) | |
267 | ||
268 | ||
269 | (defmethod compile-parenscript-form :around ((comp-env compilation-environment) form) | |
270 | (multiple-value-bind (expanded-form expanded-p) | |
271 | (expand-script-form form) | |
272 | (cond | |
273 | (expanded-p | |
274 | (compile-parenscript-form comp-env expanded-form)) | |
275 | ((comp-env-compiling-toplevel-p comp-env) | |
276 | (compile-toplevel-parenscript-form comp-env form)) | |
277 | (t (call-next-method))))) | |
278 | ||
279 | (defmethod compile-parenscript-form ((comp-env compilation-environment) (form string)) | |
280 | (make-instance 'ps-js::string-literal :value form)) | |
281 | ||
282 | (defmethod compile-parenscript-form ((comp-env compilation-environment) (form character)) | |
283 | (compile-parenscript-form comp-env (string form))) | |
284 | ||
285 | (defmethod compile-parenscript-form ((comp-env compilation-environment) (form number)) | |
286 | (make-instance 'ps-js::number-literal :value form)) | |
287 | ||
288 | (defmethod compile-parenscript-form ((comp-env compilation-environment) (form symbol)) | |
289 | ;; is this the correct behavior? | |
290 | (let ((c-macro (get-script-special-form form))) | |
291 | (cond | |
292 | (c-macro (funcall c-macro)) | |
293 | ;; the following emulates the lisp behavior that a keyword is bound to itself | |
294 | ;; see http://clhs.lisp.se/Body/t_kwd.htm | |
295 | ((keywordp form) (compile-parenscript-form comp-env `(quote ,form))) | |
296 | (t (make-instance 'ps-js::js-variable :value form))))) | |
297 | ||
298 | (defun compile-function-argument-forms (forms) | |
299 | "Compiles a bunch of Parenscript forms from a funcall form to an effective set of | |
300 | Javascript arguments. The only extra processing this does is makes :keyword arguments | |
301 | into a single options argument via CREATE." | |
302 | (flet ((keyword-arg (arg) | |
303 | "If the given compiled expression is supposed to be a keyword argument, returns | |
304 | the keyword for it." | |
305 | (when (typep arg 'script-quote) (ps-js::value arg)))) | |
306 | (let ((expressions (mapcar #'compile-to-expression forms))) | |
307 | ||
308 | (do ((effective-expressions nil) | |
309 | (expressions-subl expressions)) | |
310 | ||
311 | ((not expressions-subl) | |
312 | (nreverse effective-expressions)) | |
313 | ||
314 | (let ((arg-expr (first expressions-subl))) | |
315 | (if (keyword-arg arg-expr) | |
316 | (progn | |
317 | (when (oddp (length expressions-subl)) | |
e22d923b | 318 | (error "Odd number of keyword arguments: ~A." forms)) |
46f794a4 RD |
319 | (push |
320 | (make-instance 'ps-js::js-object | |
321 | :slots | |
322 | (loop for (name val) on expressions-subl by #'cddr | |
323 | collect (list name val))) | |
324 | effective-expressions) | |
325 | (setf expressions-subl nil)) | |
326 | (progn | |
327 | (push arg-expr effective-expressions) | |
328 | (setf expressions-subl (rest expressions-subl))))))))) | |
329 | ||
330 | (defmethod compile-parenscript-form ((comp-env compilation-environment) (form cons)) | |
331 | (let* ((name (car form)) | |
332 | (args (cdr form)) | |
d9fc64c9 | 333 | (script-form (when (symbolp name) (get-script-special-form name)))) |
46f794a4 RD |
334 | (cond |
335 | ((eql name 'quote) (make-instance 'script-quote :value (first args))) | |
336 | (script-form (apply script-form args)) | |
337 | ((ps-js::op-form-p form) | |
338 | (make-instance 'ps-js::op-form | |
339 | :operator (ps-js::script-convert-op-name (compile-to-symbol (first form))) | |
340 | :args (mapcar #'compile-to-expression (rest form)))) | |
341 | ((method-call-p form) | |
342 | (make-instance 'ps-js::method-call | |
343 | :method (compile-to-symbol name) | |
344 | :object (compile-to-expression (first args)) | |
345 | :args (compile-function-argument-forms (rest args)))) | |
346 | ((funcall-form-p form) | |
347 | (make-instance 'ps-js::function-call | |
348 | :function (compile-to-expression name) | |
349 | :args (compile-function-argument-forms args))) | |
350 | (t (error "Unknown form ~S" form))))) | |
cc4f1551 | 351 | |
9da682ca RD |
352 | (defun compile-script-form (form &key (comp-env *compilation-environment*)) |
353 | "Compiles a Parenscript form to an AST node." | |
727a0288 | 354 | (compile-parenscript-form comp-env form)) |
9da682ca RD |
355 | |
356 | (defun compile-to-expression (form) | |
357 | "Compiles the given Parenscript form and guarantees the result is an expression." | |
358 | (let ((res (compile-script-form form))) | |
5e0e55be VS |
359 | (assert (typep res 'ps-js::expression) () |
360 | "Error: ~s was expected to compile to a ParenScript expression, but instead compiled to ~s, which has type ~s" | |
361 | form res (type-of res)) | |
cc4f1551 RD |
362 | res)) |
363 | ||
9da682ca | 364 | (defun compile-to-symbol (form) |
5aa10005 RD |
365 | "Compiles the given Parenscript form and guarantees a symbolic result. This |
366 | also guarantees that the symbol has an associated script-package." | |
9da682ca | 367 | (let ((res (compile-script-form form))) |
5aa10005 RD |
368 | (when (typep res 'ps-js::js-variable) |
369 | (setf res (ps-js::value res))) | |
bbea4c83 RD |
370 | (when (typep res 'ps-js::script-quote) |
371 | (setf res (ps-js::value res))) | |
30135005 | 372 | (assert (symbolp res) () |
905f534e | 373 | "~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 |
374 | (unless (symbol-script-package res) |
375 | (when *warn-ps-package* | |
376 | (warn 'simple-style-warning | |
377 | :format-control "The symbol ~A::~A has no associated script package." | |
378 | :format-arguments (list (if (symbol-package res) (package-name (symbol-package res)) "ANONYMOUS-PACKAGE") | |
379 | res)))) | |
cc4f1551 RD |
380 | res)) |
381 | ||
9da682ca RD |
382 | (defun compile-to-statement (form) |
383 | "Compiles the given Parenscript form and guarantees the result is a statement." | |
384 | (let ((res (compile-script-form form))) | |
5aa10005 | 385 | (assert (typep res 'ps-js::statement)) |
cc4f1551 RD |
386 | res)) |
387 | ||
5aa10005 | 388 | (defun compile-to-block (form &key (indent "")) |
9da682ca RD |
389 | "Compiles the given Parenscript form and guarantees the result is of type SCRIPT-BODY" |
390 | (let ((res (compile-to-statement form))) | |
5aa10005 RD |
391 | (if (typep res 'ps-js::js-block) |
392 | (progn (setf (ps-js::block-indent res) indent) | |
cc4f1551 | 393 | res) |
5aa10005 | 394 | (make-instance 'ps-js::js-block |
cc4f1551 | 395 | :indent indent |
9da682ca | 396 | :statements (list res))))) |