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 | |
4e6c3ba1 | 202 | (defmethod ps-compile ((symbol symbol)) |
87857891 VS |
203 | (multiple-value-bind (expansion expanded?) |
204 | (ps-macroexpand symbol) | |
205 | (if expanded? | |
206 | (ps-compile expansion) | |
207 | (cond ((keywordp symbol) symbol) | |
208 | ((ps-special-form-p (list symbol)) | |
209 | (if (ps-reserved-symbol-p symbol) | |
210 | (funcall (get-ps-special-form symbol)) | |
211 | (error "Attempting to use Parenscript special form ~a as variable" symbol))) | |
212 | (t `(js:variable ,symbol)))))) | |
4a987e2b | 213 | |
a14fb2cb VS |
214 | ;;; operators |
215 | ||
4a56eb79 VS |
216 | (let ((precedence-table (make-hash-table :test 'eq))) |
217 | (loop for level in '((js:new js:slot-value js:aref) | |
218 | (postfix++ postfix--) | |
219 | (delete void typeof ++ -- unary+ unary- ~ !) | |
220 | (* / %) | |
221 | (+ -) | |
222 | (<< >> >>>) | |
223 | (< > <= >= js:instanceof js:in) | |
224 | (== != === !==) | |
225 | (&) | |
226 | (^) | |
227 | (\|) | |
228 | (\&\& and) | |
229 | (\|\| or) | |
230 | (js:?) | |
231 | (= *= /= %= += -= <<= >>= >>>= \&\= ^= \|=) | |
232 | (comma)) | |
233 | for i from 0 | |
234 | do (mapcar (lambda (symbol) | |
235 | (setf (gethash symbol precedence-table) i)) | |
236 | level)) | |
237 | (defun op-precedence (op) | |
238 | (gethash op precedence-table))) | |
a14fb2cb | 239 | |
3b16a7f3 | 240 | (defun ps-convert-op-name (op) |
b39a6394 | 241 | (case op |
3b16a7f3 TC |
242 | (and '\&\&) |
243 | (or '\|\|) | |
244 | (not '!) | |
245 | (eql '\=\=) | |
246 | (= '\=\=) | |
4e6c3ba1 | 247 | (t op))) |
3b16a7f3 | 248 | |
a14fb2cb VS |
249 | (defun maybe-fix-nary-comparison-form (form) |
250 | (if (< 2 (length (cdr form))) | |
251 | (values | |
252 | (let* ((operator (car form)) | |
253 | (tmp-var-forms (butlast (cddr form))) | |
254 | (tmp-vars (loop repeat (length tmp-var-forms) | |
255 | collect (ps-gensym "_cmp"))) | |
256 | (all-comparisons (append (list (cadr form)) | |
257 | tmp-vars | |
258 | (last form)))) | |
259 | `(let ,(mapcar #'list tmp-vars tmp-var-forms) | |
260 | (and ,@(loop for x1 in all-comparisons | |
261 | for x2 in (cdr all-comparisons) | |
262 | collect (list operator x1 x2))))) | |
263 | t) | |
264 | form)) | |
265 | ||
266 | (defun compile-op-form (form) | |
6f79326b | 267 | `(js:operator ,(ps-convert-op-name (ps-compile-symbol (car form))) |
a14fb2cb | 268 | ,@(mapcar (lambda (form) |
4e6c3ba1 | 269 | (ps-compile-expression (ps-macroexpand form))) |
a14fb2cb VS |
270 | (cdr form)))) |
271 | ||
11cba1a7 CE |
272 | (defun compile-method-call-form (form) |
273 | (compile-funcall-form | |
274 | `((js:slot-value ,(second form) | |
275 | ',(make-symbol (subseq (symbol-name (first form)) 1))) | |
276 | ,@(cddr form)))) | |
277 | ||
a14fb2cb VS |
278 | (defun compile-funcall-form (form) |
279 | `(js:funcall | |
87857891 VS |
280 | ,(if (symbolp (car form)) |
281 | `(js:variable ,(maybe-rename-local-function (car form))) | |
282 | (ps-compile-expression (ps-macroexpand (car form)))) | |
4e6c3ba1 VS |
283 | ,@(mapcar #'ps-compile-expression (cdr form)))) |
284 | ||
285 | (defvar compile-expression?) | |
286 | ||
287 | (defmethod ps-compile ((form cons)) | |
5a69278c VS |
288 | (multiple-value-bind (form expanded-p) |
289 | (ps-macroexpand form) | |
a14fb2cb VS |
290 | (let ((*ps-compilation-level* |
291 | (if expanded-p | |
292 | *ps-compilation-level* | |
293 | (adjust-ps-compilation-level form *ps-compilation-level*)))) | |
294 | (cond (expanded-p | |
4e6c3ba1 | 295 | (ps-compile form)) |
a14fb2cb | 296 | ((ps-special-form-p form) |
4e6c3ba1 | 297 | (apply (get-ps-special-form (car form)) (cdr form))) |
a14fb2cb VS |
298 | ((comparison-form-p form) |
299 | (multiple-value-bind (form fixed?) | |
300 | (maybe-fix-nary-comparison-form form) | |
301 | (if fixed? | |
4e6c3ba1 | 302 | (ps-compile form) |
a14fb2cb | 303 | (compile-op-form form)))) |
4e6c3ba1 VS |
304 | ((op-form-p form) |
305 | (compile-op-form form)) | |
11cba1a7 CE |
306 | ((method-call-form-p form) |
307 | (compile-method-call-form form)) | |
4e6c3ba1 VS |
308 | ((funcall-form-p form) |
309 | (compile-funcall-form form)) | |
11cba1a7 | 310 | (t (error "Cannot compile ~S to a ParenScript form." form)))))) |
cc4f1551 | 311 | |
4e6c3ba1 VS |
312 | (defun ps-compile-statement (form) |
313 | (let ((compile-expression? nil)) | |
314 | (ps-compile form))) | |
315 | ||
316 | (defun ps-compile-expression (form) | |
317 | (let ((compile-expression? t)) | |
318 | (ps-compile form))) | |
319 | ||
18dd299a VS |
320 | (defvar *ps-gensym-counter* 0) |
321 | ||
322 | (defun ps-gensym (&optional (prefix "_js")) | |
5ffb1eba VS |
323 | (let ((prefix (if (stringp prefix) prefix (symbol-to-js-string prefix nil)))) |
324 | (make-symbol (format nil "~A~:[~;_~]~A" prefix | |
325 | (digit-char-p (char prefix (1- (length prefix)))) | |
326 | (incf *ps-gensym-counter*))))) | |
18dd299a VS |
327 | |
328 | (defmacro with-ps-gensyms (symbols &body body) | |
329 | "Evaluate BODY with SYMBOLS bound to unique ParenScript identifiers. | |
330 | ||
331 | Each element of SYMBOLS is either a symbol or a list of (symbol | |
332 | gensym-prefix-string)." | |
333 | `(let* ,(mapcar (lambda (symbol) | |
334 | (destructuring-bind (symbol &optional prefix) | |
335 | (if (consp symbol) | |
336 | symbol | |
337 | (list symbol)) | |
338 | (if prefix | |
339 | `(,symbol (ps-gensym ,prefix)) | |
6274a448 | 340 | `(,symbol (ps-gensym ,(symbol-to-js-string symbol)))))) |
18dd299a VS |
341 | symbols) |
342 | ,@body)) | |
6ae06336 TC |
343 | |
344 | (defun %check-once-only-vars (vars) | |
345 | (let ((bad-var (find-if (lambda (x) (or (not (symbolp x)) (keywordp x))) vars))) | |
346 | (when bad-var | |
347 | (error "PS-ONLY-ONCE expected a non-keyword symbol but got ~s" bad-var)))) | |
348 | ||
349 | (defmacro ps-once-only ((&rest vars) &body body) | |
350 | (%check-once-only-vars vars) | |
351 | (let ((gensyms (mapcar (lambda (x) (ps-gensym (string x))) vars))) | |
352 | `(let ,(mapcar (lambda (g v) `(,g (ps-gensym ,(string v)))) gensyms vars) | |
353 | `(let* (,,@(mapcar (lambda (g v) ``(,,g ,,v)) gensyms vars)) | |
354 | ,(let ,(mapcar (lambda (g v) `(,v ,g)) gensyms vars) | |
355 | ,@body))))) |