Commit | Line | Data |
---|---|---|
cc4f1551 RD |
1 | (in-package :parenscript) |
2 | ||
c88be949 TC |
3 | (defvar *ps-symbols* (make-hash-table :test 'equal)) |
4 | (defvar *ps-literals* (make-hash-table :test 'eq)) | |
5 | (defvar *ps-special-forms* (make-hash-table :test 'eq)) | |
6 | ||
7 | (defclass parenscript-symbol () | |
8 | ((name :initarg :name :accessor name-of))) | |
9 | ||
10 | (defmethod print-object ((obj parenscript-symbol) stream) | |
11 | (format stream "~a" (name-of obj))) | |
12 | ||
8cf7de80 TC |
13 | (defun find-ps-symbol (symbol) |
14 | (multiple-value-bind (sym hit?) (gethash (string symbol) *ps-symbols*) | |
15 | (when hit? sym))) | |
16 | ||
c88be949 TC |
17 | (defun ps-intern (thing) |
18 | (if (typep thing 'parenscript-symbol) thing | |
19 | (let ((str (string thing))) | |
20 | (multiple-value-bind (sym hit?) (gethash str *ps-symbols*) | |
21 | (if hit? sym | |
22 | (setf (gethash str *ps-symbols*) | |
23 | (make-instance 'parenscript-symbol :name str))))))) | |
f326f929 | 24 | |
4577df1c TC |
25 | (defun get-ps-special-form (name) |
26 | "Returns the special form function corresponding to the given name." | |
8cf7de80 | 27 | (gethash (find-ps-symbol name) *ps-special-forms*)) |
4577df1c | 28 | |
c88be949 TC |
29 | (defun add-ps-literal (name &aux (sym (ps-intern name))) |
30 | (setf (gethash sym *ps-literals*) sym)) | |
4577df1c | 31 | |
c88be949 | 32 | (defun undefine-ps-special-form (name &aux (sym (ps-intern name))) |
f326f929 | 33 | "Undefines the special form with the given name (name is a symbol)." |
c88be949 TC |
34 | (remhash sym *ps-special-forms*) |
35 | (remhash sym *ps-literals*) | |
36 | t) | |
cc4f1551 | 37 | |
4a987e2b VS |
38 | (defmacro define-ps-special-form (name lambda-list &rest body) |
39 | "Define a special form NAME. The first argument given to the special | |
40 | form is a keyword indicating whether the form is expected to produce | |
41 | an :expression or a :statement. The resulting Parenscript language | |
42 | types are appended to the ongoing javascript compilation." | |
b506b81b | 43 | (let ((arglist (gensym "ps-arglist-"))) |
c88be949 TC |
44 | `(setf (gethash (ps-intern ',name) *ps-special-forms*) |
45 | (lambda (&rest ,arglist) | |
46 | (destructuring-bind ,lambda-list | |
47 | ,arglist | |
48 | ,@body))))) | |
9da682ca | 49 | |
e0032a96 VS |
50 | (defvar *enclosing-lexical-block-declarations* () |
51 | "This special variable is expected to be bound to a fresh list by | |
52 | special forms that introduce a new JavaScript lexical block (currently | |
53 | function definitions and lambdas). Enclosed special forms are expected | |
54 | to push variable declarations onto the list when the variables | |
83b5a0cc TC |
55 | declaration cannot be made by the enclosed form \(for example, a |
56 | \(x,y,z\) expression progn\). It is then the responsibility of the | |
e0032a96 VS |
57 | enclosing special form to introduce the variable bindings in its |
58 | lexical block.") | |
59 | ||
58c4ef4f VS |
60 | (defvar *ps-special-variables* ()) |
61 | ||
4a987e2b VS |
62 | ;;; ParenScript form predicates |
63 | (defun ps-special-form-p (form) | |
cc4f1551 RD |
64 | (and (consp form) |
65 | (symbolp (car form)) | |
8cf7de80 | 66 | (gethash (find-ps-symbol (car form)) *ps-special-forms*))) |
5ac90695 VS |
67 | |
68 | (defun ps-literal-p (symbol) | |
8cf7de80 | 69 | (gethash (find-ps-symbol symbol) *ps-literals*)) |
4a987e2b VS |
70 | |
71 | (defun op-form-p (form) | |
72 | (and (listp form) | |
73 | (not (ps-special-form-p form)) | |
74 | (not (null (op-precedence (first form)))))) | |
cc4f1551 | 75 | |
9da682ca RD |
76 | (defun funcall-form-p (form) |
77 | (and (listp form) | |
4a987e2b VS |
78 | (not (op-form-p form)) |
79 | (not (ps-special-form-p form)))) | |
cc4f1551 | 80 | |
9da682ca RD |
81 | (defun method-call-p (form) |
82 | (and (funcall-form-p form) | |
83 | (symbolp (first form)) | |
84 | (eql (char (symbol-name (first form)) 0) #\.))) | |
cc4f1551 | 85 | |
9da682ca | 86 | ;;; macro expansion |
cc4f1551 RD |
87 | (eval-when (:compile-toplevel :load-toplevel :execute) |
88 | (defun make-macro-env-dictionary () | |
9da682ca | 89 | "Creates a standard macro dictionary." |
06babcf5 | 90 | (make-hash-table :test #'equal)) |
462ca010 | 91 | (defvar *ps-macro-toplevel* (make-macro-env-dictionary) |
72332f2a VS |
92 | "Toplevel macro environment dictionary. Key is the symbol of the |
93 | macro, value is (symbol-macro-p . expansion-function).") | |
462ca010 | 94 | (defvar *ps-macro-env* (list *ps-macro-toplevel*) |
171bbab3 | 95 | "Current macro environment.") |
72332f2a | 96 | |
462ca010 | 97 | (defvar *ps-setf-expanders* (make-macro-env-dictionary) |
72332f2a VS |
98 | "Setf expander dictionary. Key is the symbol of the access |
99 | function of the place, value is an expansion function that takes the | |
100 | arguments of the access functions as a first value and the form to be | |
101 | stored as the second value.") | |
171bbab3 | 102 | |
06babcf5 VS |
103 | (defun get-macro-spec (name env-dict) |
104 | "Retrieves the macro spec of the given name with the given environment dictionary. | |
72332f2a | 105 | SPEC is of the form (symbol-macro-p . expansion-function)." |
8cf7de80 | 106 | (gethash (find-ps-symbol name) env-dict)) |
06babcf5 VS |
107 | (defsetf get-macro-spec (name env-dict) |
108 | (spec) | |
c88be949 | 109 | `(setf (gethash (ps-intern ,name) ,env-dict) ,spec))) |
9da682ca | 110 | |
462ca010 | 111 | (defun lookup-macro-spec (name &optional (environment *ps-macro-env*)) |
9da682ca | 112 | "Looks up the macro spec associated with NAME in the given environment. A |
905f534e | 113 | macro spec is of the form (symbol-macro-p . function). Returns two values: |
9da682ca | 114 | the SPEC and the parent macro environment. |
cc4f1551 | 115 | |
9da682ca | 116 | NAME must be a symbol." |
cc4f1551 RD |
117 | (when (symbolp name) |
118 | (do ((env environment (cdr env))) | |
119 | ((null env) nil) | |
120 | (let ((val (get-macro-spec name (car env)))) | |
121 | (when val | |
122 | (return-from lookup-macro-spec | |
123 | (values val (or (cdr env) | |
462ca010 | 124 | (list *ps-macro-toplevel*))))))))) |
cc4f1551 | 125 | |
462ca010 | 126 | (defun ps-symbol-macro-p (name &optional (environment *ps-macro-env*)) |
9da682ca | 127 | "True if there is a Parenscript symbol macro named by the symbol NAME." |
cc4f1551 RD |
128 | (and (symbolp name) (car (lookup-macro-spec name environment)))) |
129 | ||
462ca010 | 130 | (defun ps-macro-p (name &optional (environment *ps-macro-env*)) |
9da682ca RD |
131 | "True if there is a Parenscript macro named by the symbol NAME." |
132 | (and (symbolp name) | |
133 | (let ((macro-spec (lookup-macro-spec name environment))) | |
b508414b | 134 | (and macro-spec (not (car macro-spec)))))) |
cc4f1551 | 135 | |
462ca010 | 136 | (defun lookup-macro-expansion-function (name &optional (environment *ps-macro-env*)) |
cc4f1551 RD |
137 | "Lookup NAME in the given macro expansion environment (which |
138 | defaults to the current macro environment). Returns the expansion | |
139 | function and the parent macro environment of the macro." | |
140 | (multiple-value-bind (macro-spec parent-env) | |
141 | (lookup-macro-spec name environment) | |
142 | (values (cdr macro-spec) parent-env))) | |
143 | ||
e22d923b | 144 | (eval-when (:compile-toplevel :load-toplevel :execute) |
921f2e02 VS |
145 | (defun make-ps-macro-function (args body) |
146 | (let* ((whole-var (when (eql '&whole (first args)) (second args))) | |
147 | (effective-lambda-list (if whole-var (cddr args) args)) | |
148 | (form-arg (or whole-var (gensym "ps-macro-form-arg-"))) | |
149 | (body (if (and (cdr body) (stringp (first body))) (rest body) body))) ;; drop docstring | |
150 | (compile nil `(lambda (,form-arg) | |
151 | (destructuring-bind ,effective-lambda-list | |
152 | (cdr ,form-arg) | |
153 | ,@body))))) | |
154 | ||
462ca010 | 155 | (defun define-ps-macro% (name args body &key symbol-macro-p) |
921f2e02 | 156 | (undefine-ps-special-form name) |
462ca010 | 157 | (setf (get-macro-spec name *ps-macro-toplevel*) |
921f2e02 VS |
158 | (cons symbol-macro-p (make-ps-macro-function args body))) |
159 | nil)) | |
d9fc64c9 | 160 | |
4a987e2b | 161 | (defmacro defpsmacro (name args &body body) |
d9fc64c9 VS |
162 | "Define a ParenScript macro, and store it in the toplevel ParenScript |
163 | macro environment." | |
462ca010 | 164 | `(define-ps-macro% ',name ',args ',body :symbol-macro-p nil)) |
cc4f1551 | 165 | |
462ca010 | 166 | (defmacro define-ps-symbol-macro (name &body body) |
b5369cb1 | 167 | "Define a ParenScript symbol macro, and store it in the toplevel ParenScript |
46f794a4 | 168 | macro environment. BODY is a Lisp form that should return a ParenScript form." |
462ca010 | 169 | `(define-ps-macro% ',name () ',body :symbol-macro-p t)) |
b5369cb1 | 170 | |
7590646c VS |
171 | (defun import-macros-from-lisp (&rest names) |
172 | "Import the named Lisp macros into the ParenScript macro | |
173 | environment. When the imported macro is macroexpanded by ParenScript, | |
174 | it is first fully macroexpanded in the Lisp macro environment, and | |
175 | then that expansion is further expanded by ParenScript." | |
176 | (dolist (name names) | |
f1394729 | 177 | (define-ps-macro% name '(&rest args) |
e22d923b RD |
178 | (list `(common-lisp:macroexpand `(,',name ,@args))) |
179 | :symbol-macro-p nil))) | |
7590646c | 180 | |
f016e033 | 181 | (defmacro defmacro/ps (name args &body body) |
7590646c VS |
182 | "Define a Lisp macro and import it into the ParenScript macro environment." |
183 | `(progn (defmacro ,name ,args ,@body) | |
b508414b | 184 | (ps:import-macros-from-lisp ',name))) |
7590646c | 185 | |
f016e033 | 186 | (defmacro defmacro+ps (name args &body body) |
7590646c VS |
187 | "Define a Lisp macro and a ParenScript macro in their respective |
188 | macro environments. This function should be used when you want to use | |
189 | the same macro in both Lisp and ParenScript, but the 'macroexpand' of | |
190 | that macro in Lisp makes the Lisp macro unsuitable to be imported into | |
191 | the ParenScript macro environment." | |
192 | `(progn (defmacro ,name ,args ,@body) | |
4a987e2b VS |
193 | (defpsmacro ,name ,args ,@body))) |
194 | ||
195 | (defun ps-macroexpand (form) | |
196 | "Recursively macroexpands ParenScript macros and symbol-macros in | |
197 | the given ParenScript form. Returns two values: the expanded form, and | |
198 | whether any expansion was performed on the form or not." | |
199 | (if (consp form) | |
200 | (let ((op (car form)) | |
201 | (args (cdr form))) | |
45c9f9c2 | 202 | (cond ((equal op 'quote) (values (if (equalp '(nil) args) nil form) ; leave quotes alone, unless it's a quoted nil |
43a1d5c3 | 203 | nil)) |
462ca010 | 204 | ((ps-macro-p op) (values (ps-macroexpand (funcall (lookup-macro-expansion-function op) form)) t)) |
4a987e2b | 205 | (t (values form nil)))) |
462ca010 | 206 | (cond ((ps-symbol-macro-p form) (values (ps-macroexpand (funcall (lookup-macro-expansion-function form) (list form))) t)) |
4a987e2b VS |
207 | (t (values form nil))))) |
208 | ||
209 | ;;;; compiler interface | |
210 | (defgeneric compile-parenscript-form (form &key expecting) | |
211 | (:documentation "Compiles a ParenScript form to the intermediate | |
212 | ParenScript representation. :expecting determines whether the form is | |
213 | compiled to an :expression (the default), a :statement, or a | |
214 | :symbol.")) | |
215 | ||
216 | (defmethod compile-parenscript-form :around (form &key expecting) | |
e0032a96 | 217 | (assert (if expecting (member expecting '(:expression :statement :symbol)) t)) |
4a987e2b VS |
218 | (if (eql expecting :symbol) |
219 | (compile-to-symbol form) | |
220 | (multiple-value-bind (expanded-form expanded-p) | |
221 | (ps-macroexpand form) | |
222 | (if expanded-p | |
a589bb43 | 223 | (compile-parenscript-form expanded-form :expecting expecting) |
4a987e2b VS |
224 | (call-next-method))))) |
225 | ||
226 | (defun compile-to-symbol (form) | |
227 | "Compiles the given Parenscript form and guarantees that the | |
228 | resultant symbol has an associated script-package. Raises an error if | |
229 | the form cannot be compiled to a symbol." | |
230 | (let ((exp (compile-parenscript-form form))) | |
231 | (when (or (eql (first exp) 'js-variable) | |
462ca010 | 232 | (eql (first exp) 'ps-quote)) |
4a987e2b VS |
233 | (setf exp (second exp))) |
234 | (assert (symbolp exp) () | |
235 | "~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) | |
236 | exp)) | |
237 | ||
238 | (defmethod compile-parenscript-form (form &key expecting) | |
239 | (declare (ignore expecting)) | |
240 | (error "The object ~S cannot be compiled by ParenScript." form)) | |
241 | ||
242 | (defmethod compile-parenscript-form ((form number) &key expecting) | |
243 | (declare (ignore expecting)) | |
244 | form) | |
245 | ||
246 | (defmethod compile-parenscript-form ((form string) &key expecting) | |
247 | (declare (ignore expecting)) | |
248 | form) | |
249 | ||
250 | (defmethod compile-parenscript-form ((form character) &key expecting) | |
251 | (declare (ignore expecting)) | |
252 | (compile-parenscript-form (string form))) | |
253 | ||
254 | (defmethod compile-parenscript-form ((symbol symbol) &key expecting) | |
255 | (declare (ignore expecting)) | |
f326f929 VS |
256 | (cond ((ps-special-form-p (list symbol)) |
257 | (if (ps-literal-p symbol) | |
258 | (funcall (get-ps-special-form symbol) :symbol) | |
259 | (error "Attempting to use Parenscript special form ~a as variable" symbol))) | |
260 | (t (list 'js-variable symbol)))) | |
4a987e2b VS |
261 | |
262 | (defun compile-function-argument-forms (arg-forms) | |
46f794a4 RD |
263 | "Compiles a bunch of Parenscript forms from a funcall form to an effective set of |
264 | Javascript arguments. The only extra processing this does is makes :keyword arguments | |
265 | into a single options argument via CREATE." | |
266 | (flet ((keyword-arg (arg) | |
b508414b | 267 | "If the given compiled expression is supposed to be a keyword argument, returns |
46f794a4 | 268 | the keyword for it." |
462ca010 | 269 | (when (and (listp arg) (eql (first arg) 'ps-quote)) (second arg)))) |
e5253c5b VS |
270 | (let ((compiled-args (mapcar (lambda (arg) (compile-parenscript-form arg :expecting :expression)) |
271 | arg-forms))) | |
4a987e2b VS |
272 | (do ((effective-expressions nil) |
273 | (expressions-subl compiled-args)) | |
274 | ((not expressions-subl) (reverse effective-expressions)) | |
275 | (let ((arg-expr (first expressions-subl))) | |
276 | (if (keyword-arg arg-expr) | |
277 | (progn (when (oddp (length expressions-subl)) | |
278 | (error "Odd number of keyword arguments: ~A." arg-forms)) | |
279 | (push (list 'js-object (loop for (name val) on expressions-subl by #'cddr | |
280 | collect (list name val))) | |
281 | effective-expressions) | |
282 | (setf expressions-subl nil)) | |
283 | (progn (push arg-expr effective-expressions) | |
284 | (setf expressions-subl (rest expressions-subl))))))))) | |
285 | ||
3b16a7f3 TC |
286 | (defun ps-convert-op-name (op) |
287 | (case (ensure-ps-symbol op) | |
288 | (and '\&\&) | |
289 | (or '\|\|) | |
290 | (not '!) | |
291 | (eql '\=\=) | |
292 | (= '\=\=) | |
293 | (t op))) | |
294 | ||
4a987e2b | 295 | (defmethod compile-parenscript-form ((form cons) &key (expecting :statement)) |
46f794a4 | 296 | (let* ((name (car form)) |
b508414b | 297 | (args (cdr form))) |
4a987e2b VS |
298 | (cond ((eql name 'quote) |
299 | (assert (= 1 (length args)) () "Wrong number of arguments to quote: ~s" args) | |
462ca010 | 300 | (list 'ps-quote (first args))) |
4a987e2b VS |
301 | ((ps-special-form-p form) (apply (get-ps-special-form name) (cons expecting args))) |
302 | ((op-form-p form) | |
303 | (list 'operator | |
462ca010 | 304 | (ps-convert-op-name (compile-parenscript-form (first form) :expecting :symbol)) |
4a987e2b VS |
305 | (mapcar (lambda (form) (compile-parenscript-form form :expecting :expression)) (rest form)))) |
306 | ((method-call-p form) | |
307 | (list 'js-method-call | |
308 | (compile-parenscript-form name :expecting :symbol) | |
309 | (compile-parenscript-form (first args) :expecting :expression) | |
310 | (compile-function-argument-forms (rest args)))) | |
311 | ((funcall-form-p form) | |
312 | (list 'js-funcall | |
313 | (compile-parenscript-form name :expecting :expression) | |
314 | (compile-function-argument-forms args))) | |
315 | (t (error "Cannot compile ~S to a ParenScript form." form))))) | |
cc4f1551 | 316 | |
18dd299a VS |
317 | (defvar *ps-gensym-counter* 0) |
318 | ||
319 | (defun ps-gensym (&optional (prefix "_js")) | |
320 | (make-symbol (format nil "~A~A" prefix (incf *ps-gensym-counter*)))) | |
321 | ||
322 | (defmacro with-ps-gensyms (symbols &body body) | |
323 | "Evaluate BODY with SYMBOLS bound to unique ParenScript identifiers. | |
324 | ||
325 | Each element of SYMBOLS is either a symbol or a list of (symbol | |
326 | gensym-prefix-string)." | |
327 | `(let* ,(mapcar (lambda (symbol) | |
328 | (destructuring-bind (symbol &optional prefix) | |
329 | (if (consp symbol) | |
330 | symbol | |
331 | (list symbol)) | |
332 | (if prefix | |
333 | `(,symbol (ps-gensym ,prefix)) | |
b5e0bcb7 | 334 | `(,symbol (ps-gensym ,(symbol-to-js symbol)))))) |
18dd299a VS |
335 | symbols) |
336 | ,@body)) | |
6ae06336 TC |
337 | |
338 | (defun %check-once-only-vars (vars) | |
339 | (let ((bad-var (find-if (lambda (x) (or (not (symbolp x)) (keywordp x))) vars))) | |
340 | (when bad-var | |
341 | (error "PS-ONLY-ONCE expected a non-keyword symbol but got ~s" bad-var)))) | |
342 | ||
343 | (defmacro ps-once-only ((&rest vars) &body body) | |
344 | (%check-once-only-vars vars) | |
345 | (let ((gensyms (mapcar (lambda (x) (ps-gensym (string x))) vars))) | |
346 | `(let ,(mapcar (lambda (g v) `(,g (ps-gensym ,(string v)))) gensyms vars) | |
347 | `(let* (,,@(mapcar (lambda (g v) ``(,,g ,,v)) gensyms vars)) | |
348 | ,(let ,(mapcar (lambda (g v) `(,v ,g)) gensyms vars) | |
349 | ,@body))))) |