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 | |
9da682ca | 71 | (defun funcall-form-p (form) |
5a69278c VS |
72 | (and form |
73 | (listp form) | |
4a987e2b VS |
74 | (not (op-form-p form)) |
75 | (not (ps-special-form-p form)))) | |
cc4f1551 | 76 | |
9da682ca | 77 | ;;; macro expansion |
cc4f1551 | 78 | (eval-when (:compile-toplevel :load-toplevel :execute) |
5a69278c | 79 | (defun make-macro-dictionary () |
72044f33 | 80 | (make-hash-table :test 'eq)) |
5a69278c VS |
81 | |
82 | (defvar *ps-macro-toplevel* (make-macro-dictionary) | |
83 | "Toplevel macro environment dictionary.") | |
8877a380 | 84 | |
462ca010 | 85 | (defvar *ps-macro-env* (list *ps-macro-toplevel*) |
171bbab3 | 86 | "Current macro environment.") |
72332f2a | 87 | |
5a69278c VS |
88 | (defvar *ps-symbol-macro-toplevel* (make-macro-dictionary)) |
89 | ||
90 | (defvar *ps-symbol-macro-env* (list *ps-symbol-macro-toplevel*)) | |
91 | ||
92 | (defvar *ps-local-function-names* ()) | |
93 | ||
94 | (defvar *ps-setf-expanders* (make-macro-dictionary) | |
72332f2a VS |
95 | "Setf expander dictionary. Key is the symbol of the access |
96 | function of the place, value is an expansion function that takes the | |
97 | arguments of the access functions as a first value and the form to be | |
98 | stored as the second value.") | |
8877a380 | 99 | |
5a69278c | 100 | (defparameter *ps-compilation-level* :toplevel |
8877a380 VS |
101 | "This value takes on the following values: |
102 | :toplevel indicates that we are traversing toplevel forms. | |
4e6c3ba1 | 103 | :inside-toplevel-form indicates that we are inside a call to ps-compile-* |
5a69278c VS |
104 | nil indicates we are no longer toplevel-related.")) |
105 | ||
106 | (defun lookup-macro-def (name env) | |
107 | (loop for e in env thereis (gethash name e))) | |
cc4f1551 | 108 | |
8cfc6fe9 VS |
109 | (defun make-ps-macro-function (args body) |
110 | (let* ((whole-var (when (eql '&whole (first args)) (second args))) | |
111 | (effective-lambda-list (if whole-var (cddr args) args)) | |
112 | (whole-arg (or whole-var (gensym "ps-macro-form-arg-")))) | |
113 | `(lambda (,whole-arg) | |
114 | (destructuring-bind ,effective-lambda-list | |
115 | (cdr ,whole-arg) | |
116 | ,@body)))) | |
d9fc64c9 | 117 | |
4a987e2b | 118 | (defmacro defpsmacro (name args &body body) |
8cfc6fe9 | 119 | `(progn (undefine-ps-special-form ',name) |
5a69278c | 120 | (setf (gethash ',name *ps-macro-toplevel*) ,(make-ps-macro-function args body)) |
8cfc6fe9 | 121 | ',name)) |
cc4f1551 | 122 | |
8cfc6fe9 | 123 | (defmacro define-ps-symbol-macro (symbol expansion) |
fb469285 VS |
124 | (let ((x (gensym))) |
125 | `(progn (undefine-ps-special-form ',symbol) | |
5a69278c | 126 | (setf (gethash ',symbol *ps-symbol-macro-toplevel*) (lambda (,x) (declare (ignore ,x)) ',expansion)) |
fb469285 | 127 | ',symbol))) |
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) | |
8cfc6fe9 VS |
135 | (eval `(defpsmacro ,name (&rest args) |
136 | (macroexpand `(,',name ,@args)))))) | |
7590646c | 137 | |
f016e033 | 138 | (defmacro defmacro/ps (name args &body body) |
7590646c VS |
139 | "Define a Lisp macro and import it into the ParenScript macro environment." |
140 | `(progn (defmacro ,name ,args ,@body) | |
8cfc6fe9 | 141 | (import-macros-from-lisp ',name))) |
7590646c | 142 | |
f016e033 | 143 | (defmacro defmacro+ps (name args &body body) |
8cfc6fe9 VS |
144 | "Define a Lisp macro and a ParenScript macro with the same macro |
145 | function (ie - the same result from macroexpand-1), for cases when the | |
146 | two have different full macroexpansions (for example if the CL macro | |
147 | contains implementation-specific code when macroexpanded fully in the | |
148 | CL environment)." | |
7590646c | 149 | `(progn (defmacro ,name ,args ,@body) |
4a987e2b VS |
150 | (defpsmacro ,name ,args ,@body))) |
151 | ||
152 | (defun ps-macroexpand (form) | |
62baa0d8 | 153 | (aif (or (and (symbolp form) (lookup-macro-def form *ps-symbol-macro-env*)) |
5a69278c VS |
154 | (and (consp form) (lookup-macro-def (car form) *ps-macro-env*))) |
155 | (values (ps-macroexpand (funcall it form)) t) | |
156 | form)) | |
157 | ||
158 | (defun maybe-rename-local-function (fun-name) | |
159 | (aif (lookup-macro-def fun-name *ps-local-function-names*) | |
160 | it | |
161 | fun-name)) | |
4a987e2b VS |
162 | |
163 | ;;;; compiler interface | |
5a69278c | 164 | (defun adjust-ps-compilation-level (form level) |
0f5e99ff RD |
165 | "Given the current *ps-compilation-level*, LEVEL, and the fully macroexpanded |
166 | form, FORM, returns the new value for *ps-compilation-level*." | |
167 | (cond ((or (and (consp form) (member (car form) | |
168 | '(progn locally macrolet symbol-macrolet compile-file))) | |
169 | (and (symbolp form) (eq :toplevel level))) | |
170 | level) | |
171 | ((eq :toplevel level) :inside-toplevel-form))) | |
172 | ||
8877a380 | 173 | |
6f79326b | 174 | (defun ps-compile-symbol (form) |
4a987e2b VS |
175 | "Compiles the given Parenscript form and guarantees that the |
176 | resultant symbol has an associated script-package. Raises an error if | |
177 | the form cannot be compiled to a symbol." | |
4e6c3ba1 | 178 | (let ((exp (ps-compile-expression form))) |
0ce67a33 | 179 | (when (eq (first exp) 'js:variable) |
4a987e2b VS |
180 | (setf exp (second exp))) |
181 | (assert (symbolp exp) () | |
182 | "~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) | |
183 | exp)) | |
184 | ||
4e6c3ba1 | 185 | (defmethod ps-compile (form) |
4a987e2b VS |
186 | (error "The object ~S cannot be compiled by ParenScript." form)) |
187 | ||
4e6c3ba1 | 188 | (defmethod ps-compile ((form number)) |
4a987e2b VS |
189 | form) |
190 | ||
4e6c3ba1 | 191 | (defmethod ps-compile ((form string)) |
4a987e2b VS |
192 | form) |
193 | ||
4e6c3ba1 VS |
194 | (defmethod ps-compile ((form character)) |
195 | (ps-compile (string form))) | |
4a987e2b | 196 | |
4e6c3ba1 | 197 | (defmethod ps-compile ((symbol symbol)) |
5a69278c VS |
198 | (when (eq *ps-compilation-level* :toplevel) |
199 | (multiple-value-bind (expansion expanded-p) | |
200 | (ps-macroexpand symbol) | |
201 | (when expanded-p | |
4e6c3ba1 | 202 | (return-from ps-compile (ps-compile expansion))))) |
f2bb932e VS |
203 | (cond ((keywordp symbol) symbol) |
204 | ((ps-special-form-p (list symbol)) | |
837bcc37 | 205 | (if (ps-reserved-symbol-p symbol) |
4e6c3ba1 | 206 | (funcall (get-ps-special-form symbol)) |
f326f929 | 207 | (error "Attempting to use Parenscript special form ~a as variable" symbol))) |
0ce67a33 | 208 | (t `(js:variable ,symbol)))) |
4a987e2b | 209 | |
a14fb2cb VS |
210 | ;;; operators |
211 | ||
212 | (defun op-precedence (op) | |
213 | (position op | |
214 | '((js:new js:slot-value js:aref) | |
215 | (postfix++ postfix--) | |
216 | (delete void typeof ++ -- unary+ unary- ~ !) | |
217 | (* / %) | |
218 | (+ -) | |
219 | (<< >> >>>) | |
220 | (< > <= >= js:instanceof js:in) | |
221 | (== != === !==) | |
222 | (&) | |
223 | (^) | |
224 | (\|) | |
225 | (\&\& and) | |
226 | (\|\| or) | |
227 | (js:?) | |
228 | (= *= /= %= += -= <<= >>= >>>= \&\= ^= \|=) | |
229 | (comma)) | |
230 | :test #'member)) | |
231 | ||
3b16a7f3 | 232 | (defun ps-convert-op-name (op) |
b39a6394 | 233 | (case op |
3b16a7f3 TC |
234 | (and '\&\&) |
235 | (or '\|\|) | |
236 | (not '!) | |
237 | (eql '\=\=) | |
238 | (= '\=\=) | |
4e6c3ba1 | 239 | (t op))) |
3b16a7f3 | 240 | |
a14fb2cb VS |
241 | (defun maybe-fix-nary-comparison-form (form) |
242 | (if (< 2 (length (cdr form))) | |
243 | (values | |
244 | (let* ((operator (car form)) | |
245 | (tmp-var-forms (butlast (cddr form))) | |
246 | (tmp-vars (loop repeat (length tmp-var-forms) | |
247 | collect (ps-gensym "_cmp"))) | |
248 | (all-comparisons (append (list (cadr form)) | |
249 | tmp-vars | |
250 | (last form)))) | |
251 | `(let ,(mapcar #'list tmp-vars tmp-var-forms) | |
252 | (and ,@(loop for x1 in all-comparisons | |
253 | for x2 in (cdr all-comparisons) | |
254 | collect (list operator x1 x2))))) | |
255 | t) | |
256 | form)) | |
257 | ||
258 | (defun compile-op-form (form) | |
6f79326b | 259 | `(js:operator ,(ps-convert-op-name (ps-compile-symbol (car form))) |
a14fb2cb | 260 | ,@(mapcar (lambda (form) |
4e6c3ba1 | 261 | (ps-compile-expression (ps-macroexpand form))) |
a14fb2cb VS |
262 | (cdr form)))) |
263 | ||
264 | (defun compile-funcall-form (form) | |
265 | `(js:funcall | |
4e6c3ba1 VS |
266 | ,(ps-compile-expression (if (symbolp (car form)) |
267 | (maybe-rename-local-function (car form)) | |
268 | (ps-macroexpand (car form)))) | |
269 | ,@(mapcar #'ps-compile-expression (cdr form)))) | |
270 | ||
271 | (defvar compile-expression?) | |
272 | ||
273 | (defmethod ps-compile ((form cons)) | |
5a69278c VS |
274 | (multiple-value-bind (form expanded-p) |
275 | (ps-macroexpand form) | |
a14fb2cb VS |
276 | (let ((*ps-compilation-level* |
277 | (if expanded-p | |
278 | *ps-compilation-level* | |
279 | (adjust-ps-compilation-level form *ps-compilation-level*)))) | |
280 | (cond (expanded-p | |
4e6c3ba1 | 281 | (ps-compile form)) |
a14fb2cb | 282 | ((ps-special-form-p form) |
4e6c3ba1 | 283 | (apply (get-ps-special-form (car form)) (cdr form))) |
a14fb2cb VS |
284 | ((comparison-form-p form) |
285 | (multiple-value-bind (form fixed?) | |
286 | (maybe-fix-nary-comparison-form form) | |
287 | (if fixed? | |
4e6c3ba1 | 288 | (ps-compile form) |
a14fb2cb | 289 | (compile-op-form form)))) |
4e6c3ba1 VS |
290 | ((op-form-p form) |
291 | (compile-op-form form)) | |
292 | ((funcall-form-p form) | |
293 | (compile-funcall-form form)) | |
a14fb2cb | 294 | (t (error "Cannot compile ~S to a ParenScript form." form)))))) |
cc4f1551 | 295 | |
4e6c3ba1 VS |
296 | (defun ps-compile-statement (form) |
297 | (let ((compile-expression? nil)) | |
298 | (ps-compile form))) | |
299 | ||
300 | (defun ps-compile-expression (form) | |
301 | (let ((compile-expression? t)) | |
302 | (ps-compile form))) | |
303 | ||
18dd299a VS |
304 | (defvar *ps-gensym-counter* 0) |
305 | ||
306 | (defun ps-gensym (&optional (prefix "_js")) | |
5ffb1eba VS |
307 | (let ((prefix (if (stringp prefix) prefix (symbol-to-js-string prefix nil)))) |
308 | (make-symbol (format nil "~A~:[~;_~]~A" prefix | |
309 | (digit-char-p (char prefix (1- (length prefix)))) | |
310 | (incf *ps-gensym-counter*))))) | |
18dd299a VS |
311 | |
312 | (defmacro with-ps-gensyms (symbols &body body) | |
313 | "Evaluate BODY with SYMBOLS bound to unique ParenScript identifiers. | |
314 | ||
315 | Each element of SYMBOLS is either a symbol or a list of (symbol | |
316 | gensym-prefix-string)." | |
317 | `(let* ,(mapcar (lambda (symbol) | |
318 | (destructuring-bind (symbol &optional prefix) | |
319 | (if (consp symbol) | |
320 | symbol | |
321 | (list symbol)) | |
322 | (if prefix | |
323 | `(,symbol (ps-gensym ,prefix)) | |
6274a448 | 324 | `(,symbol (ps-gensym ,(symbol-to-js-string symbol)))))) |
18dd299a VS |
325 | symbols) |
326 | ,@body)) | |
6ae06336 TC |
327 | |
328 | (defun %check-once-only-vars (vars) | |
329 | (let ((bad-var (find-if (lambda (x) (or (not (symbolp x)) (keywordp x))) vars))) | |
330 | (when bad-var | |
331 | (error "PS-ONLY-ONCE expected a non-keyword symbol but got ~s" bad-var)))) | |
332 | ||
333 | (defmacro ps-once-only ((&rest vars) &body body) | |
334 | (%check-once-only-vars vars) | |
335 | (let ((gensyms (mapcar (lambda (x) (ps-gensym (string x))) vars))) | |
336 | `(let ,(mapcar (lambda (g v) `(,g (ps-gensym ,(string v)))) gensyms vars) | |
337 | `(let* (,,@(mapcar (lambda (g v) ``(,,g ,,v)) gensyms vars)) | |
338 | ,(let ,(mapcar (lambda (g v) `(,v ,g)) gensyms vars) | |
339 | ,@body))))) |