Commit | Line | Data |
---|---|---|
e8fdcce7 | 1 | (in-package "PARENSCRIPT") |
cc4f1551 | 2 | |
72044f33 | 3 | ;;; reserved symbols/literals |
c88be949 | 4 | |
b934060d VS |
5 | (defvar *ps-reserved-symbol-names* |
6 | (list "break" "case" "catch" "continue" "default" "delete" "do" "else" | |
7 | "finally" "for" "function" "if" "in" "instanceof" "new" "return" | |
8 | "switch" "this" "throw" "try" "typeof" "var" "void" "while" "with" | |
9 | "abstract" "boolean" "byte" "char" "class" "const" "debugger" "double" | |
10 | "enum" "export" "extends" "final" "float" "goto" "implements" "import" | |
11 | "int" "interface" "long" "native" "package" "private" "protected" | |
12 | "public" "short" "static" "super" "synchronized" "throws" "transient" | |
13 | "volatile")) | |
c88be949 | 14 | |
837bcc37 | 15 | (defun add-ps-reserved-symbol (name) |
b934060d | 16 | (pushnew (symbol-name-to-js-string name) *ps-reserved-symbol-names* :test #'equalp)) |
c88be949 | 17 | |
837bcc37 | 18 | (defun ps-reserved-symbol-p (symbol) |
fc772f72 VS |
19 | (when (symbolp symbol) |
20 | (find (symbol-name-to-js-string symbol) *ps-reserved-symbol-names* :test #'equalp))) | |
8cf7de80 | 21 | |
72044f33 | 22 | ;;; special forms |
f326f929 | 23 | |
72044f33 | 24 | (defvar *ps-special-forms* (make-hash-table :test 'eq)) |
4577df1c | 25 | |
72044f33 VS |
26 | (defun get-ps-special-form (name) |
27 | (gethash name *ps-special-forms*)) | |
cc4f1551 | 28 | |
4a987e2b | 29 | (defmacro define-ps-special-form (name lambda-list &rest body) |
4e6c3ba1 VS |
30 | `(setf (gethash ',name *ps-special-forms*) |
31 | (lambda (&rest whole) | |
32 | (destructuring-bind ,lambda-list | |
33 | whole | |
34 | ,@body)))) | |
9da682ca | 35 | |
72044f33 VS |
36 | (defun undefine-ps-special-form (name) |
37 | (remhash name *ps-special-forms*)) | |
38 | ||
39 | (defun ps-special-form-p (form) | |
40 | (and (consp form) | |
41 | (symbolp (car form)) | |
42 | (gethash (car form) *ps-special-forms*))) | |
43 | ||
44 | ;;; scoping | |
45 | ||
e0032a96 VS |
46 | (defvar *enclosing-lexical-block-declarations* () |
47 | "This special variable is expected to be bound to a fresh list by | |
48 | special forms that introduce a new JavaScript lexical block (currently | |
49 | function definitions and lambdas). Enclosed special forms are expected | |
50 | to push variable declarations onto the list when the variables | |
83b5a0cc TC |
51 | declaration cannot be made by the enclosed form \(for example, a |
52 | \(x,y,z\) expression progn\). It is then the responsibility of the | |
e0032a96 VS |
53 | enclosing special form to introduce the variable bindings in its |
54 | lexical block.") | |
55 | ||
58c4ef4f VS |
56 | (defvar *ps-special-variables* ()) |
57 | ||
5ffb1eba VS |
58 | (defun ps-special-variable-p (sym) |
59 | (member sym *ps-special-variables*)) | |
60 | ||
72044f33 | 61 | ;;; form predicates |
4a987e2b | 62 | |
a14fb2cb VS |
63 | (defun comparison-form-p (form) |
64 | (member (car form) '(< > <= >= == != === !==))) | |
65 | ||
4a987e2b VS |
66 | (defun op-form-p (form) |
67 | (and (listp form) | |
68 | (not (ps-special-form-p form)) | |
69 | (not (null (op-precedence (first form)))))) | |
cc4f1551 | 70 | |
11cba1a7 CE |
71 | (defun method-call-form-p (form) |
72 | (and (listp form) | |
73 | (symbolp (car form)) | |
74 | (char= #\. (char (symbol-name (car form)) 0)))) | |
75 | ||
9da682ca | 76 | (defun funcall-form-p (form) |
5a69278c VS |
77 | (and form |
78 | (listp form) | |
4a987e2b VS |
79 | (not (op-form-p form)) |
80 | (not (ps-special-form-p form)))) | |
cc4f1551 | 81 | |
9da682ca | 82 | ;;; macro expansion |
cc4f1551 | 83 | (eval-when (:compile-toplevel :load-toplevel :execute) |
5a69278c | 84 | (defun make-macro-dictionary () |
72044f33 | 85 | (make-hash-table :test 'eq)) |
5a69278c VS |
86 | |
87 | (defvar *ps-macro-toplevel* (make-macro-dictionary) | |
88 | "Toplevel macro environment dictionary.") | |
8877a380 | 89 | |
462ca010 | 90 | (defvar *ps-macro-env* (list *ps-macro-toplevel*) |
171bbab3 | 91 | "Current macro environment.") |
72332f2a | 92 | |
5a69278c VS |
93 | (defvar *ps-symbol-macro-toplevel* (make-macro-dictionary)) |
94 | ||
95 | (defvar *ps-symbol-macro-env* (list *ps-symbol-macro-toplevel*)) | |
96 | ||
97 | (defvar *ps-local-function-names* ()) | |
98 | ||
99 | (defvar *ps-setf-expanders* (make-macro-dictionary) | |
72332f2a VS |
100 | "Setf expander dictionary. Key is the symbol of the access |
101 | function of the place, value is an expansion function that takes the | |
102 | arguments of the access functions as a first value and the form to be | |
103 | stored as the second value.") | |
8877a380 | 104 | |
5a69278c | 105 | (defparameter *ps-compilation-level* :toplevel |
8877a380 VS |
106 | "This value takes on the following values: |
107 | :toplevel indicates that we are traversing toplevel forms. | |
4e6c3ba1 | 108 | :inside-toplevel-form indicates that we are inside a call to ps-compile-* |
5a69278c VS |
109 | nil indicates we are no longer toplevel-related.")) |
110 | ||
111 | (defun lookup-macro-def (name env) | |
112 | (loop for e in env thereis (gethash name e))) | |
cc4f1551 | 113 | |
8cfc6fe9 VS |
114 | (defun make-ps-macro-function (args body) |
115 | (let* ((whole-var (when (eql '&whole (first args)) (second args))) | |
116 | (effective-lambda-list (if whole-var (cddr args) args)) | |
117 | (whole-arg (or whole-var (gensym "ps-macro-form-arg-")))) | |
118 | `(lambda (,whole-arg) | |
119 | (destructuring-bind ,effective-lambda-list | |
120 | (cdr ,whole-arg) | |
121 | ,@body)))) | |
d9fc64c9 | 122 | |
4a987e2b | 123 | (defmacro defpsmacro (name args &body body) |
8cfc6fe9 | 124 | `(progn (undefine-ps-special-form ',name) |
5a69278c | 125 | (setf (gethash ',name *ps-macro-toplevel*) ,(make-ps-macro-function args body)) |
8cfc6fe9 | 126 | ',name)) |
cc4f1551 | 127 | |
8cfc6fe9 | 128 | (defmacro define-ps-symbol-macro (symbol expansion) |
fb469285 VS |
129 | (let ((x (gensym))) |
130 | `(progn (undefine-ps-special-form ',symbol) | |
5a69278c | 131 | (setf (gethash ',symbol *ps-symbol-macro-toplevel*) (lambda (,x) (declare (ignore ,x)) ',expansion)) |
fb469285 | 132 | ',symbol))) |
b5369cb1 | 133 | |
7590646c VS |
134 | (defun import-macros-from-lisp (&rest names) |
135 | "Import the named Lisp macros into the ParenScript macro | |
136 | environment. When the imported macro is macroexpanded by ParenScript, | |
137 | it is first fully macroexpanded in the Lisp macro environment, and | |
138 | then that expansion is further expanded by ParenScript." | |
139 | (dolist (name names) | |
8cfc6fe9 VS |
140 | (eval `(defpsmacro ,name (&rest args) |
141 | (macroexpand `(,',name ,@args)))))) | |
7590646c | 142 | |
f016e033 | 143 | (defmacro defmacro/ps (name args &body body) |
7590646c VS |
144 | "Define a Lisp macro and import it into the ParenScript macro environment." |
145 | `(progn (defmacro ,name ,args ,@body) | |
8cfc6fe9 | 146 | (import-macros-from-lisp ',name))) |
7590646c | 147 | |
f016e033 | 148 | (defmacro defmacro+ps (name args &body body) |
8cfc6fe9 VS |
149 | "Define a Lisp macro and a ParenScript macro with the same macro |
150 | function (ie - the same result from macroexpand-1), for cases when the | |
151 | two have different full macroexpansions (for example if the CL macro | |
152 | contains implementation-specific code when macroexpanded fully in the | |
153 | CL environment)." | |
7590646c | 154 | `(progn (defmacro ,name ,args ,@body) |
4a987e2b VS |
155 | (defpsmacro ,name ,args ,@body))) |
156 | ||
157 | (defun ps-macroexpand (form) | |
62baa0d8 | 158 | (aif (or (and (symbolp form) (lookup-macro-def form *ps-symbol-macro-env*)) |
5a69278c VS |
159 | (and (consp form) (lookup-macro-def (car form) *ps-macro-env*))) |
160 | (values (ps-macroexpand (funcall it form)) t) | |
161 | form)) | |
162 | ||
163 | (defun maybe-rename-local-function (fun-name) | |
164 | (aif (lookup-macro-def fun-name *ps-local-function-names*) | |
165 | it | |
166 | fun-name)) | |
4a987e2b VS |
167 | |
168 | ;;;; compiler interface | |
5a69278c | 169 | (defun adjust-ps-compilation-level (form level) |
0f5e99ff RD |
170 | "Given the current *ps-compilation-level*, LEVEL, and the fully macroexpanded |
171 | form, FORM, returns the new value for *ps-compilation-level*." | |
172 | (cond ((or (and (consp form) (member (car form) | |
173 | '(progn locally macrolet symbol-macrolet compile-file))) | |
174 | (and (symbolp form) (eq :toplevel level))) | |
175 | level) | |
176 | ((eq :toplevel level) :inside-toplevel-form))) | |
177 | ||
8877a380 | 178 | |
6f79326b | 179 | (defun ps-compile-symbol (form) |
4a987e2b VS |
180 | "Compiles the given Parenscript form and guarantees that the |
181 | resultant symbol has an associated script-package. Raises an error if | |
182 | the form cannot be compiled to a symbol." | |
4e6c3ba1 | 183 | (let ((exp (ps-compile-expression form))) |
0ce67a33 | 184 | (when (eq (first exp) 'js:variable) |
4a987e2b VS |
185 | (setf exp (second exp))) |
186 | (assert (symbolp exp) () | |
187 | "~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) | |
188 | exp)) | |
189 | ||
4e6c3ba1 | 190 | (defmethod ps-compile (form) |
4a987e2b VS |
191 | (error "The object ~S cannot be compiled by ParenScript." form)) |
192 | ||
4e6c3ba1 | 193 | (defmethod ps-compile ((form number)) |
4a987e2b VS |
194 | form) |
195 | ||
4e6c3ba1 | 196 | (defmethod ps-compile ((form string)) |
4a987e2b VS |
197 | form) |
198 | ||
4e6c3ba1 VS |
199 | (defmethod ps-compile ((form character)) |
200 | (ps-compile (string form))) | |
4a987e2b | 201 | |
0c804d25 CE |
202 | (defun compound-symbol-p (symbol) |
203 | (let ((split (split-sequence:split-sequence #\. (symbol-name symbol)))) | |
204 | (break "~A = ~A" symbol split) | |
205 | (if (cdr split) | |
206 | (reduce | |
207 | (lambda (&optional slot-name object-exp) | |
208 | `(js:slot-value ,object-exp ,(make-symbol slot-name))) | |
209 | (reverse (cddr split)) | |
210 | :initial-value `(slot-value | |
211 | (js:variable ,(ps-macroexpand | |
212 | (intern (car split) | |
213 | (symbol-package symbol)))) | |
214 | ,(make-symbol (cadr split))) | |
215 | :from-end t) | |
216 | nil))) | |
217 | ||
4e6c3ba1 | 218 | (defmethod ps-compile ((symbol symbol)) |
87857891 VS |
219 | (multiple-value-bind (expansion expanded?) |
220 | (ps-macroexpand symbol) | |
221 | (if expanded? | |
222 | (ps-compile expansion) | |
223 | (cond ((keywordp symbol) symbol) | |
224 | ((ps-special-form-p (list symbol)) | |
225 | (if (ps-reserved-symbol-p symbol) | |
226 | (funcall (get-ps-special-form symbol)) | |
227 | (error "Attempting to use Parenscript special form ~a as variable" symbol))) | |
c2c51a3d CE |
228 | (t (aif (compound-symbol-p symbol) |
229 | it | |
230 | `(js:variable ,symbol))))))) | |
4a987e2b | 231 | |
a14fb2cb VS |
232 | ;;; operators |
233 | ||
4a56eb79 VS |
234 | (let ((precedence-table (make-hash-table :test 'eq))) |
235 | (loop for level in '((js:new js:slot-value js:aref) | |
236 | (postfix++ postfix--) | |
237 | (delete void typeof ++ -- unary+ unary- ~ !) | |
238 | (* / %) | |
239 | (+ -) | |
240 | (<< >> >>>) | |
241 | (< > <= >= js:instanceof js:in) | |
242 | (== != === !==) | |
243 | (&) | |
244 | (^) | |
245 | (\|) | |
246 | (\&\& and) | |
247 | (\|\| or) | |
248 | (js:?) | |
249 | (= *= /= %= += -= <<= >>= >>>= \&\= ^= \|=) | |
250 | (comma)) | |
251 | for i from 0 | |
252 | do (mapcar (lambda (symbol) | |
253 | (setf (gethash symbol precedence-table) i)) | |
254 | level)) | |
255 | (defun op-precedence (op) | |
256 | (gethash op precedence-table))) | |
a14fb2cb | 257 | |
3b16a7f3 | 258 | (defun ps-convert-op-name (op) |
b39a6394 | 259 | (case op |
3b16a7f3 TC |
260 | (and '\&\&) |
261 | (or '\|\|) | |
262 | (not '!) | |
263 | (eql '\=\=) | |
264 | (= '\=\=) | |
4e6c3ba1 | 265 | (t op))) |
3b16a7f3 | 266 | |
a14fb2cb VS |
267 | (defun maybe-fix-nary-comparison-form (form) |
268 | (if (< 2 (length (cdr form))) | |
269 | (values | |
270 | (let* ((operator (car form)) | |
271 | (tmp-var-forms (butlast (cddr form))) | |
272 | (tmp-vars (loop repeat (length tmp-var-forms) | |
273 | collect (ps-gensym "_cmp"))) | |
274 | (all-comparisons (append (list (cadr form)) | |
275 | tmp-vars | |
276 | (last form)))) | |
277 | `(let ,(mapcar #'list tmp-vars tmp-var-forms) | |
278 | (and ,@(loop for x1 in all-comparisons | |
279 | for x2 in (cdr all-comparisons) | |
280 | collect (list operator x1 x2))))) | |
281 | t) | |
282 | form)) | |
283 | ||
284 | (defun compile-op-form (form) | |
6f79326b | 285 | `(js:operator ,(ps-convert-op-name (ps-compile-symbol (car form))) |
a14fb2cb | 286 | ,@(mapcar (lambda (form) |
4e6c3ba1 | 287 | (ps-compile-expression (ps-macroexpand form))) |
a14fb2cb VS |
288 | (cdr form)))) |
289 | ||
11cba1a7 CE |
290 | (defun compile-method-call-form (form) |
291 | (compile-funcall-form | |
292 | `((js:slot-value ,(second form) | |
293 | ',(make-symbol (subseq (symbol-name (first form)) 1))) | |
294 | ,@(cddr form)))) | |
295 | ||
c2c51a3d CE |
296 | (defun function-name->js-expression (name) |
297 | (aif (compound-symbol-p name) | |
298 | it | |
299 | `(js:variable ,(maybe-rename-local-function name)))) | |
300 | ||
a14fb2cb VS |
301 | (defun compile-funcall-form (form) |
302 | `(js:funcall | |
87857891 | 303 | ,(if (symbolp (car form)) |
c2c51a3d | 304 | (function-name->js-expression (car form)) |
87857891 | 305 | (ps-compile-expression (ps-macroexpand (car form)))) |
4e6c3ba1 VS |
306 | ,@(mapcar #'ps-compile-expression (cdr form)))) |
307 | ||
308 | (defvar compile-expression?) | |
309 | ||
310 | (defmethod ps-compile ((form cons)) | |
5a69278c VS |
311 | (multiple-value-bind (form expanded-p) |
312 | (ps-macroexpand form) | |
a14fb2cb VS |
313 | (let ((*ps-compilation-level* |
314 | (if expanded-p | |
315 | *ps-compilation-level* | |
316 | (adjust-ps-compilation-level form *ps-compilation-level*)))) | |
317 | (cond (expanded-p | |
4e6c3ba1 | 318 | (ps-compile form)) |
a14fb2cb | 319 | ((ps-special-form-p form) |
4e6c3ba1 | 320 | (apply (get-ps-special-form (car form)) (cdr form))) |
a14fb2cb VS |
321 | ((comparison-form-p form) |
322 | (multiple-value-bind (form fixed?) | |
323 | (maybe-fix-nary-comparison-form form) | |
324 | (if fixed? | |
4e6c3ba1 | 325 | (ps-compile form) |
a14fb2cb | 326 | (compile-op-form form)))) |
4e6c3ba1 VS |
327 | ((op-form-p form) |
328 | (compile-op-form form)) | |
11cba1a7 CE |
329 | ((method-call-form-p form) |
330 | (compile-method-call-form form)) | |
4e6c3ba1 VS |
331 | ((funcall-form-p form) |
332 | (compile-funcall-form form)) | |
11cba1a7 | 333 | (t (error "Cannot compile ~S to a ParenScript form." form)))))) |
cc4f1551 | 334 | |
4e6c3ba1 VS |
335 | (defun ps-compile-statement (form) |
336 | (let ((compile-expression? nil)) | |
337 | (ps-compile form))) | |
338 | ||
339 | (defun ps-compile-expression (form) | |
340 | (let ((compile-expression? t)) | |
341 | (ps-compile form))) | |
342 | ||
18dd299a VS |
343 | (defvar *ps-gensym-counter* 0) |
344 | ||
345 | (defun ps-gensym (&optional (prefix "_js")) | |
5ffb1eba VS |
346 | (let ((prefix (if (stringp prefix) prefix (symbol-to-js-string prefix nil)))) |
347 | (make-symbol (format nil "~A~:[~;_~]~A" prefix | |
348 | (digit-char-p (char prefix (1- (length prefix)))) | |
349 | (incf *ps-gensym-counter*))))) | |
18dd299a VS |
350 | |
351 | (defmacro with-ps-gensyms (symbols &body body) | |
352 | "Evaluate BODY with SYMBOLS bound to unique ParenScript identifiers. | |
353 | ||
354 | Each element of SYMBOLS is either a symbol or a list of (symbol | |
355 | gensym-prefix-string)." | |
356 | `(let* ,(mapcar (lambda (symbol) | |
357 | (destructuring-bind (symbol &optional prefix) | |
358 | (if (consp symbol) | |
359 | symbol | |
360 | (list symbol)) | |
361 | (if prefix | |
362 | `(,symbol (ps-gensym ,prefix)) | |
6274a448 | 363 | `(,symbol (ps-gensym ,(symbol-to-js-string symbol)))))) |
18dd299a VS |
364 | symbols) |
365 | ,@body)) | |
6ae06336 TC |
366 | |
367 | (defun %check-once-only-vars (vars) | |
368 | (let ((bad-var (find-if (lambda (x) (or (not (symbolp x)) (keywordp x))) vars))) | |
369 | (when bad-var | |
370 | (error "PS-ONLY-ONCE expected a non-keyword symbol but got ~s" bad-var)))) | |
371 | ||
372 | (defmacro ps-once-only ((&rest vars) &body body) | |
373 | (%check-once-only-vars vars) | |
374 | (let ((gensyms (mapcar (lambda (x) (ps-gensym (string x))) vars))) | |
375 | `(let ,(mapcar (lambda (g v) `(,g (ps-gensym ,(string v)))) gensyms vars) | |
376 | `(let* (,,@(mapcar (lambda (g v) ``(,,g ,,v)) gensyms vars)) | |
377 | ,(let ,(mapcar (lambda (g v) `(,v ,g)) gensyms vars) | |
378 | ,@body))))) |