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