Commit | Line | Data |
---|---|---|
cc4f1551 RD |
1 | (in-package :parenscript) |
2 | ||
9da682ca | 3 | ;;;; The mechanisms for defining macros & parsing Parenscript. |
cc4f1551 | 4 | (eval-when (:compile-toplevel :load-toplevel :execute) |
b506b81b | 5 | (defvar *toplevel-special-forms* (make-hash-table :test #'equal) |
9da682ca RD |
6 | "A hash-table containing functions that implement Parenscript special forms, |
7 | indexed by name (as symbols)") | |
4a987e2b | 8 | (defun undefine-ps-special-form (name) |
9da682ca | 9 | "Undefines the special form with the given name (name is a symbol)." |
06babcf5 | 10 | (remhash (lisp-symbol-to-ps-identifier name :special-form) *toplevel-special-forms*))) |
cc4f1551 | 11 | |
4a987e2b VS |
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." | |
b506b81b | 17 | (let ((arglist (gensym "ps-arglist-"))) |
06babcf5 | 18 | `(setf (gethash (lisp-symbol-to-ps-identifier ',name :special-form) *toplevel-special-forms*) |
b506b81b VS |
19 | (lambda (&rest ,arglist) |
20 | (destructuring-bind ,lambda-list | |
21 | ,arglist | |
22 | ,@body))))) | |
9da682ca | 23 | |
4a987e2b | 24 | (defun get-ps-special-form (name) |
9da682ca | 25 | "Returns the special form function corresponding to the given name." |
06babcf5 | 26 | (gethash (lisp-symbol-to-ps-identifier name :special-form) *toplevel-special-forms*)) |
cc4f1551 | 27 | |
4a987e2b VS |
28 | ;;; ParenScript form predicates |
29 | (defun ps-special-form-p (form) | |
cc4f1551 RD |
30 | (and (consp form) |
31 | (symbolp (car form)) | |
4a987e2b VS |
32 | (get-ps-special-form (car form)))) |
33 | ||
34 | (defun op-form-p (form) | |
35 | (and (listp form) | |
36 | (not (ps-special-form-p form)) | |
37 | (not (null (op-precedence (first form)))))) | |
cc4f1551 | 38 | |
9da682ca RD |
39 | (defun funcall-form-p (form) |
40 | (and (listp form) | |
4a987e2b VS |
41 | (not (op-form-p form)) |
42 | (not (ps-special-form-p form)))) | |
cc4f1551 | 43 | |
9da682ca RD |
44 | (defun method-call-p (form) |
45 | (and (funcall-form-p form) | |
46 | (symbolp (first form)) | |
47 | (eql (char (symbol-name (first form)) 0) #\.))) | |
cc4f1551 | 48 | |
9da682ca | 49 | ;;; macro expansion |
cc4f1551 RD |
50 | (eval-when (:compile-toplevel :load-toplevel :execute) |
51 | (defun make-macro-env-dictionary () | |
9da682ca | 52 | "Creates a standard macro dictionary." |
06babcf5 | 53 | (make-hash-table :test #'equal)) |
9da682ca | 54 | (defvar *script-macro-toplevel* (make-macro-env-dictionary) |
72332f2a VS |
55 | "Toplevel macro environment dictionary. Key is the symbol of the |
56 | macro, value is (symbol-macro-p . expansion-function).") | |
06babcf5 | 57 | (defvar *script-macro-env* (list *script-macro-toplevel*) |
171bbab3 | 58 | "Current macro environment.") |
72332f2a VS |
59 | |
60 | (defvar *script-setf-expanders* (make-macro-env-dictionary) | |
61 | "Setf expander dictionary. Key is the symbol of the access | |
62 | function of the place, value is an expansion function that takes the | |
63 | arguments of the access functions as a first value and the form to be | |
64 | stored as the second value.") | |
171bbab3 | 65 | |
06babcf5 VS |
66 | (defun get-macro-spec (name env-dict) |
67 | "Retrieves the macro spec of the given name with the given environment dictionary. | |
72332f2a | 68 | SPEC is of the form (symbol-macro-p . expansion-function)." |
06babcf5 VS |
69 | (gethash (lisp-symbol-to-ps-identifier name :macro) env-dict)) |
70 | (defsetf get-macro-spec (name env-dict) | |
71 | (spec) | |
72 | `(setf (gethash (lisp-symbol-to-ps-identifier ,name :macro) ,env-dict) ,spec))) | |
9da682ca RD |
73 | |
74 | (defun lookup-macro-spec (name &optional (environment *script-macro-env*)) | |
75 | "Looks up the macro spec associated with NAME in the given environment. A | |
905f534e | 76 | macro spec is of the form (symbol-macro-p . function). Returns two values: |
9da682ca | 77 | the SPEC and the parent macro environment. |
cc4f1551 | 78 | |
9da682ca | 79 | NAME must be a symbol." |
cc4f1551 RD |
80 | (when (symbolp name) |
81 | (do ((env environment (cdr env))) | |
82 | ((null env) nil) | |
83 | (let ((val (get-macro-spec name (car env)))) | |
84 | (when val | |
85 | (return-from lookup-macro-spec | |
86 | (values val (or (cdr env) | |
9da682ca | 87 | (list *script-macro-toplevel*))))))))) |
cc4f1551 | 88 | |
9da682ca RD |
89 | (defun script-symbol-macro-p (name &optional (environment *script-macro-env*)) |
90 | "True if there is a Parenscript symbol macro named by the symbol NAME." | |
cc4f1551 RD |
91 | (and (symbolp name) (car (lookup-macro-spec name environment)))) |
92 | ||
9da682ca RD |
93 | (defun script-macro-p (name &optional (environment *script-macro-env*)) |
94 | "True if there is a Parenscript macro named by the symbol NAME." | |
95 | (and (symbolp name) | |
96 | (let ((macro-spec (lookup-macro-spec name environment))) | |
97 | (and macro-spec (not (car macro-spec)))))) | |
cc4f1551 | 98 | |
9da682ca | 99 | (defun lookup-macro-expansion-function (name &optional (environment *script-macro-env*)) |
cc4f1551 RD |
100 | "Lookup NAME in the given macro expansion environment (which |
101 | defaults to the current macro environment). Returns the expansion | |
102 | function and the parent macro environment of the macro." | |
103 | (multiple-value-bind (macro-spec parent-env) | |
104 | (lookup-macro-spec name environment) | |
105 | (values (cdr macro-spec) parent-env))) | |
106 | ||
e22d923b RD |
107 | (eval-when (:compile-toplevel :load-toplevel :execute) |
108 | (defun define-script-macro% (name args body &key symbol-macro-p) | |
e22d923b RD |
109 | (let ((lambda-list (gensym "ps-lambda-list-")) |
110 | (body (if (and (cdr body) (stringp (first body))) (rest body) body))) ;; drop docstring | |
4a987e2b | 111 | (undefine-ps-special-form name) |
e22d923b RD |
112 | (setf (get-macro-spec name *script-macro-toplevel*) |
113 | (cons symbol-macro-p (compile nil `(lambda (&rest ,lambda-list) | |
114 | (destructuring-bind ,args | |
115 | ,lambda-list | |
116 | ,@body))))) | |
117 | nil))) | |
d9fc64c9 | 118 | |
4a987e2b | 119 | (defmacro defpsmacro (name args &body body) |
d9fc64c9 VS |
120 | "Define a ParenScript macro, and store it in the toplevel ParenScript |
121 | macro environment." | |
e22d923b | 122 | `(define-script-macro% ',name ',args ',body :symbol-macro-p nil)) |
cc4f1551 | 123 | |
46f794a4 | 124 | (defmacro define-script-symbol-macro (name &body body) |
b5369cb1 | 125 | "Define a ParenScript symbol macro, and store it in the toplevel ParenScript |
46f794a4 | 126 | macro environment. BODY is a Lisp form that should return a ParenScript form." |
e22d923b | 127 | `(define-script-macro% ',name () ',body :symbol-macro-p t)) |
b5369cb1 | 128 | |
7590646c VS |
129 | (defun import-macros-from-lisp (&rest names) |
130 | "Import the named Lisp macros into the ParenScript macro | |
131 | environment. When the imported macro is macroexpanded by ParenScript, | |
132 | it is first fully macroexpanded in the Lisp macro environment, and | |
133 | then that expansion is further expanded by ParenScript." | |
134 | (dolist (name names) | |
e22d923b RD |
135 | (define-script-macro% name '(&rest args) |
136 | (list `(common-lisp:macroexpand `(,',name ,@args))) | |
137 | :symbol-macro-p nil))) | |
7590646c | 138 | |
f016e033 | 139 | (defmacro defmacro/ps (name args &body body) |
7590646c VS |
140 | "Define a Lisp macro and import it into the ParenScript macro environment." |
141 | `(progn (defmacro ,name ,args ,@body) | |
f016e033 | 142 | (ps:import-macros-from-lisp ',name))) |
7590646c | 143 | |
f016e033 | 144 | (defmacro defmacro+ps (name args &body body) |
7590646c VS |
145 | "Define a Lisp macro and a ParenScript macro in their respective |
146 | macro environments. This function should be used when you want to use | |
147 | the same macro in both Lisp and ParenScript, but the 'macroexpand' of | |
148 | that macro in Lisp makes the Lisp macro unsuitable to be imported into | |
149 | the ParenScript macro environment." | |
150 | `(progn (defmacro ,name ,args ,@body) | |
4a987e2b VS |
151 | (defpsmacro ,name ,args ,@body))) |
152 | ||
153 | (defun ps-macroexpand (form) | |
154 | "Recursively macroexpands ParenScript macros and symbol-macros in | |
155 | the given ParenScript form. Returns two values: the expanded form, and | |
156 | whether any expansion was performed on the form or not." | |
157 | (if (consp form) | |
158 | (let ((op (car form)) | |
159 | (args (cdr form))) | |
46f794a4 RD |
160 | (cond ((equal op 'quote) |
161 | (values | |
4a987e2b | 162 | (if (equalp '(nil) args) nil form) ;; leave quotes alone, unless it's a quoted nil |
46f794a4 | 163 | nil)) |
9da682ca RD |
164 | ((script-macro-p op) ;; recursively expand parenscript macros in parent env. |
165 | (multiple-value-bind (expansion-function macro-env) | |
166 | (lookup-macro-expansion-function op) | |
46f794a4 | 167 | (values |
4a987e2b | 168 | (ps-macroexpand (let ((*script-macro-env* macro-env)) |
46f794a4 RD |
169 | (apply expansion-function args))) |
170 | t))) | |
4a987e2b VS |
171 | (t (values form nil)))) |
172 | (cond ((script-symbol-macro-p form) | |
9da682ca RD |
173 | ;; recursively expand symbol macros in parent env. |
174 | (multiple-value-bind (expansion-function macro-env) | |
4a987e2b | 175 | (lookup-macro-expansion-function form) |
46f794a4 | 176 | (values |
4a987e2b | 177 | (ps-macroexpand (let ((*script-macro-env* macro-env)) |
46f794a4 RD |
178 | (funcall expansion-function))) |
179 | t))) | |
9da682ca | 180 | ;; leave anything else alone |
4a987e2b VS |
181 | (t (values form nil))))) |
182 | ||
183 | ;;;; compiler interface | |
184 | (defgeneric compile-parenscript-form (form &key expecting) | |
185 | (:documentation "Compiles a ParenScript form to the intermediate | |
186 | ParenScript representation. :expecting determines whether the form is | |
187 | compiled to an :expression (the default), a :statement, or a | |
188 | :symbol.")) | |
189 | ||
190 | (defmethod compile-parenscript-form :around (form &key expecting) | |
191 | (if (eql expecting :symbol) | |
192 | (compile-to-symbol form) | |
193 | (multiple-value-bind (expanded-form expanded-p) | |
194 | (ps-macroexpand form) | |
195 | (if expanded-p | |
196 | (compile-parenscript-form expanded-form) | |
197 | (call-next-method))))) | |
198 | ||
199 | (defun compile-to-symbol (form) | |
200 | "Compiles the given Parenscript form and guarantees that the | |
201 | resultant symbol has an associated script-package. Raises an error if | |
202 | the form cannot be compiled to a symbol." | |
203 | (let ((exp (compile-parenscript-form form))) | |
204 | (when (or (eql (first exp) 'js-variable) | |
205 | (eql (first exp) 'script-quote)) | |
206 | (setf exp (second exp))) | |
207 | (assert (symbolp exp) () | |
208 | "~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) | |
209 | exp)) | |
210 | ||
211 | (defmethod compile-parenscript-form (form &key expecting) | |
212 | (declare (ignore expecting)) | |
213 | (error "The object ~S cannot be compiled by ParenScript." form)) | |
214 | ||
215 | (defmethod compile-parenscript-form ((form number) &key expecting) | |
216 | (declare (ignore expecting)) | |
217 | form) | |
218 | ||
219 | (defmethod compile-parenscript-form ((form string) &key expecting) | |
220 | (declare (ignore expecting)) | |
221 | form) | |
222 | ||
223 | (defmethod compile-parenscript-form ((form character) &key expecting) | |
224 | (declare (ignore expecting)) | |
225 | (compile-parenscript-form (string form))) | |
226 | ||
227 | (defmethod compile-parenscript-form ((symbol symbol) &key expecting) | |
228 | (declare (ignore expecting)) | |
46f794a4 | 229 | ;; is this the correct behavior? |
4a987e2b VS |
230 | (let ((special-symbol (get-ps-special-form symbol))) |
231 | (cond (special-symbol (funcall special-symbol :symbol)) | |
232 | ;; the following emulates the lisp behavior that a keyword is bound to itself | |
233 | ;; see http://clhs.lisp.se/Body/t_kwd.htm | |
234 | ((keywordp symbol) (compile-parenscript-form `(quote ,symbol))) | |
235 | (t (list 'js-variable symbol))))) | |
236 | ||
237 | (defun compile-function-argument-forms (arg-forms) | |
46f794a4 RD |
238 | "Compiles a bunch of Parenscript forms from a funcall form to an effective set of |
239 | Javascript arguments. The only extra processing this does is makes :keyword arguments | |
240 | into a single options argument via CREATE." | |
241 | (flet ((keyword-arg (arg) | |
242 | "If the given compiled expression is supposed to be a keyword argument, returns | |
243 | the keyword for it." | |
4a987e2b VS |
244 | (when (and (listp arg) (eql (first arg) 'script-quote)) (second arg)))) |
245 | (let ((compiled-args (mapcar #'compile-parenscript-form arg-forms))) | |
246 | (do ((effective-expressions nil) | |
247 | (expressions-subl compiled-args)) | |
248 | ((not expressions-subl) (reverse effective-expressions)) | |
249 | (let ((arg-expr (first expressions-subl))) | |
250 | (if (keyword-arg arg-expr) | |
251 | (progn (when (oddp (length expressions-subl)) | |
252 | (error "Odd number of keyword arguments: ~A." arg-forms)) | |
253 | (push (list 'js-object (loop for (name val) on expressions-subl by #'cddr | |
254 | collect (list name val))) | |
255 | effective-expressions) | |
256 | (setf expressions-subl nil)) | |
257 | (progn (push arg-expr effective-expressions) | |
258 | (setf expressions-subl (rest expressions-subl))))))))) | |
259 | ||
260 | (defmethod compile-parenscript-form ((form cons) &key (expecting :statement)) | |
46f794a4 | 261 | (let* ((name (car form)) |
4a987e2b VS |
262 | (args (cdr form))) |
263 | (cond ((eql name 'quote) | |
264 | (assert (= 1 (length args)) () "Wrong number of arguments to quote: ~s" args) | |
265 | (list 'script-quote (first args))) | |
266 | ((ps-special-form-p form) (apply (get-ps-special-form name) (cons expecting args))) | |
267 | ((op-form-p form) | |
268 | (list 'operator | |
269 | (script-convert-op-name (compile-parenscript-form (first form) :expecting :symbol)) | |
270 | (mapcar (lambda (form) (compile-parenscript-form form :expecting :expression)) (rest form)))) | |
271 | ((method-call-p form) | |
272 | (list 'js-method-call | |
273 | (compile-parenscript-form name :expecting :symbol) | |
274 | (compile-parenscript-form (first args) :expecting :expression) | |
275 | (compile-function-argument-forms (rest args)))) | |
276 | ((funcall-form-p form) | |
277 | (list 'js-funcall | |
278 | (compile-parenscript-form name :expecting :expression) | |
279 | (compile-function-argument-forms args))) | |
280 | (t (error "Cannot compile ~S to a ParenScript form." form))))) | |
cc4f1551 | 281 |