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 | 65 | (defun funcall-form-p (form) |
5a69278c VS |
66 | (and form |
67 | (listp form) | |
4a987e2b VS |
68 | (not (op-form-p form)) |
69 | (not (ps-special-form-p form)))) | |
cc4f1551 | 70 | |
9da682ca | 71 | ;;; macro expansion |
cc4f1551 | 72 | (eval-when (:compile-toplevel :load-toplevel :execute) |
5a69278c | 73 | (defun make-macro-dictionary () |
72044f33 | 74 | (make-hash-table :test 'eq)) |
5a69278c VS |
75 | |
76 | (defvar *ps-macro-toplevel* (make-macro-dictionary) | |
77 | "Toplevel macro environment dictionary.") | |
8877a380 | 78 | |
462ca010 | 79 | (defvar *ps-macro-env* (list *ps-macro-toplevel*) |
171bbab3 | 80 | "Current macro environment.") |
72332f2a | 81 | |
5a69278c VS |
82 | (defvar *ps-symbol-macro-toplevel* (make-macro-dictionary)) |
83 | ||
84 | (defvar *ps-symbol-macro-env* (list *ps-symbol-macro-toplevel*)) | |
85 | ||
86 | (defvar *ps-local-function-names* ()) | |
87 | ||
88 | (defvar *ps-setf-expanders* (make-macro-dictionary) | |
72332f2a VS |
89 | "Setf expander dictionary. Key is the symbol of the access |
90 | function of the place, value is an expansion function that takes the | |
91 | arguments of the access functions as a first value and the form to be | |
92 | stored as the second value.") | |
8877a380 | 93 | |
5a69278c | 94 | (defparameter *ps-compilation-level* :toplevel |
8877a380 VS |
95 | "This value takes on the following values: |
96 | :toplevel indicates that we are traversing toplevel forms. | |
97 | :inside-toplevel-form indicates that we are inside a call to compile-parenscript-form | |
5a69278c VS |
98 | nil indicates we are no longer toplevel-related.")) |
99 | ||
100 | (defun lookup-macro-def (name env) | |
101 | (loop for e in env thereis (gethash name e))) | |
cc4f1551 | 102 | |
8cfc6fe9 VS |
103 | (defun make-ps-macro-function (args body) |
104 | (let* ((whole-var (when (eql '&whole (first args)) (second args))) | |
105 | (effective-lambda-list (if whole-var (cddr args) args)) | |
106 | (whole-arg (or whole-var (gensym "ps-macro-form-arg-")))) | |
107 | `(lambda (,whole-arg) | |
108 | (destructuring-bind ,effective-lambda-list | |
109 | (cdr ,whole-arg) | |
110 | ,@body)))) | |
d9fc64c9 | 111 | |
4a987e2b | 112 | (defmacro defpsmacro (name args &body body) |
8cfc6fe9 | 113 | `(progn (undefine-ps-special-form ',name) |
5a69278c | 114 | (setf (gethash ',name *ps-macro-toplevel*) ,(make-ps-macro-function args body)) |
8cfc6fe9 | 115 | ',name)) |
cc4f1551 | 116 | |
8cfc6fe9 | 117 | (defmacro define-ps-symbol-macro (symbol expansion) |
fb469285 VS |
118 | (let ((x (gensym))) |
119 | `(progn (undefine-ps-special-form ',symbol) | |
5a69278c | 120 | (setf (gethash ',symbol *ps-symbol-macro-toplevel*) (lambda (,x) (declare (ignore ,x)) ',expansion)) |
fb469285 | 121 | ',symbol))) |
b5369cb1 | 122 | |
7590646c VS |
123 | (defun import-macros-from-lisp (&rest names) |
124 | "Import the named Lisp macros into the ParenScript macro | |
125 | environment. When the imported macro is macroexpanded by ParenScript, | |
126 | it is first fully macroexpanded in the Lisp macro environment, and | |
127 | then that expansion is further expanded by ParenScript." | |
128 | (dolist (name names) | |
8cfc6fe9 VS |
129 | (eval `(defpsmacro ,name (&rest args) |
130 | (macroexpand `(,',name ,@args)))))) | |
7590646c | 131 | |
f016e033 | 132 | (defmacro defmacro/ps (name args &body body) |
7590646c VS |
133 | "Define a Lisp macro and import it into the ParenScript macro environment." |
134 | `(progn (defmacro ,name ,args ,@body) | |
8cfc6fe9 | 135 | (import-macros-from-lisp ',name))) |
7590646c | 136 | |
f016e033 | 137 | (defmacro defmacro+ps (name args &body body) |
8cfc6fe9 VS |
138 | "Define a Lisp macro and a ParenScript macro with the same macro |
139 | function (ie - the same result from macroexpand-1), for cases when the | |
140 | two have different full macroexpansions (for example if the CL macro | |
141 | contains implementation-specific code when macroexpanded fully in the | |
142 | CL environment)." | |
7590646c | 143 | `(progn (defmacro ,name ,args ,@body) |
4a987e2b VS |
144 | (defpsmacro ,name ,args ,@body))) |
145 | ||
146 | (defun ps-macroexpand (form) | |
5a69278c VS |
147 | (aif (or (lookup-macro-def form *ps-symbol-macro-env*) |
148 | (and (consp form) (lookup-macro-def (car form) *ps-macro-env*))) | |
149 | (values (ps-macroexpand (funcall it form)) t) | |
150 | form)) | |
151 | ||
152 | (defun maybe-rename-local-function (fun-name) | |
153 | (aif (lookup-macro-def fun-name *ps-local-function-names*) | |
154 | it | |
155 | fun-name)) | |
4a987e2b VS |
156 | |
157 | ;;;; compiler interface | |
158 | (defgeneric compile-parenscript-form (form &key expecting) | |
159 | (:documentation "Compiles a ParenScript form to the intermediate | |
160 | ParenScript representation. :expecting determines whether the form is | |
161 | compiled to an :expression (the default), a :statement, or a | |
162 | :symbol.")) | |
163 | ||
5a69278c VS |
164 | (defun adjust-ps-compilation-level (form level) |
165 | (cond ((or (and (consp form) (eq 'progn (car form))) | |
166 | (and (symbolp form) (eq :toplevel level))) | |
167 | level) | |
168 | ((eq :toplevel level) :inside-toplevel-form))) | |
8877a380 | 169 | |
4a987e2b | 170 | (defmethod compile-parenscript-form :around (form &key expecting) |
e0032a96 | 171 | (assert (if expecting (member expecting '(:expression :statement :symbol)) t)) |
5a69278c | 172 | (if (eq expecting :symbol) |
4a987e2b | 173 | (compile-to-symbol form) |
5a69278c VS |
174 | (let ((*ps-compilation-level* (adjust-ps-compilation-level form *ps-compilation-level*))) |
175 | (call-next-method)))) | |
4a987e2b VS |
176 | |
177 | (defun compile-to-symbol (form) | |
178 | "Compiles the given Parenscript form and guarantees that the | |
179 | resultant symbol has an associated script-package. Raises an error if | |
180 | the form cannot be compiled to a symbol." | |
5a69278c | 181 | (let ((exp (compile-parenscript-form form :expecting :expression))) |
0ce67a33 | 182 | (when (eq (first exp) 'js:variable) |
4a987e2b VS |
183 | (setf exp (second exp))) |
184 | (assert (symbolp exp) () | |
185 | "~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) | |
186 | exp)) | |
187 | ||
188 | (defmethod compile-parenscript-form (form &key expecting) | |
189 | (declare (ignore expecting)) | |
190 | (error "The object ~S cannot be compiled by ParenScript." form)) | |
191 | ||
192 | (defmethod compile-parenscript-form ((form number) &key expecting) | |
193 | (declare (ignore expecting)) | |
194 | form) | |
195 | ||
196 | (defmethod compile-parenscript-form ((form string) &key expecting) | |
197 | (declare (ignore expecting)) | |
198 | form) | |
199 | ||
200 | (defmethod compile-parenscript-form ((form character) &key expecting) | |
201 | (declare (ignore expecting)) | |
202 | (compile-parenscript-form (string form))) | |
203 | ||
204 | (defmethod compile-parenscript-form ((symbol symbol) &key expecting) | |
5a69278c VS |
205 | (when (eq *ps-compilation-level* :toplevel) |
206 | (multiple-value-bind (expansion expanded-p) | |
207 | (ps-macroexpand symbol) | |
208 | (when expanded-p | |
209 | (return-from compile-parenscript-form (compile-parenscript-form expansion :expecting expecting))))) | |
f2bb932e VS |
210 | (cond ((keywordp symbol) symbol) |
211 | ((ps-special-form-p (list symbol)) | |
f326f929 VS |
212 | (if (ps-literal-p symbol) |
213 | (funcall (get-ps-special-form symbol) :symbol) | |
214 | (error "Attempting to use Parenscript special form ~a as variable" symbol))) | |
0ce67a33 | 215 | (t `(js:variable ,symbol)))) |
4a987e2b | 216 | |
3b16a7f3 | 217 | (defun ps-convert-op-name (op) |
b39a6394 | 218 | (case op |
3b16a7f3 TC |
219 | (and '\&\&) |
220 | (or '\|\|) | |
221 | (not '!) | |
222 | (eql '\=\=) | |
223 | (= '\=\=) | |
224 | (t op))) | |
225 | ||
4a987e2b | 226 | (defmethod compile-parenscript-form ((form cons) &key (expecting :statement)) |
5a69278c VS |
227 | (multiple-value-bind (form expanded-p) |
228 | (ps-macroexpand form) | |
229 | (cond (expanded-p (compile-parenscript-form form :expecting expecting)) | |
230 | ((ps-special-form-p form) (apply (get-ps-special-form (car form)) (cons expecting (cdr form)))) | |
4a987e2b | 231 | ((op-form-p form) |
5a69278c VS |
232 | `(js:operator ,(ps-convert-op-name (compile-parenscript-form (car form) :expecting :symbol)) |
233 | ,@(mapcar (lambda (form) | |
234 | (compile-parenscript-form (ps-macroexpand form) :expecting :expression)) | |
235 | (cdr form)))) | |
4a987e2b | 236 | ((funcall-form-p form) |
5a69278c VS |
237 | `(js:funcall ,(compile-parenscript-form (if (symbolp (car form)) |
238 | (maybe-rename-local-function (car form)) | |
239 | (ps-macroexpand (car form))) | |
240 | :expecting :expression) | |
241 | ,@(mapcar (lambda (arg) | |
242 | (compile-parenscript-form (ps-macroexpand arg) :expecting :expression)) | |
243 | (cdr form)))) | |
4a987e2b | 244 | (t (error "Cannot compile ~S to a ParenScript form." form))))) |
cc4f1551 | 245 | |
18dd299a VS |
246 | (defvar *ps-gensym-counter* 0) |
247 | ||
248 | (defun ps-gensym (&optional (prefix "_js")) | |
5ffb1eba VS |
249 | (let ((prefix (if (stringp prefix) prefix (symbol-to-js-string prefix nil)))) |
250 | (make-symbol (format nil "~A~:[~;_~]~A" prefix | |
251 | (digit-char-p (char prefix (1- (length prefix)))) | |
252 | (incf *ps-gensym-counter*))))) | |
18dd299a VS |
253 | |
254 | (defmacro with-ps-gensyms (symbols &body body) | |
255 | "Evaluate BODY with SYMBOLS bound to unique ParenScript identifiers. | |
256 | ||
257 | Each element of SYMBOLS is either a symbol or a list of (symbol | |
258 | gensym-prefix-string)." | |
259 | `(let* ,(mapcar (lambda (symbol) | |
260 | (destructuring-bind (symbol &optional prefix) | |
261 | (if (consp symbol) | |
262 | symbol | |
263 | (list symbol)) | |
264 | (if prefix | |
265 | `(,symbol (ps-gensym ,prefix)) | |
6274a448 | 266 | `(,symbol (ps-gensym ,(symbol-to-js-string symbol)))))) |
18dd299a VS |
267 | symbols) |
268 | ,@body)) | |
6ae06336 TC |
269 | |
270 | (defun %check-once-only-vars (vars) | |
271 | (let ((bad-var (find-if (lambda (x) (or (not (symbolp x)) (keywordp x))) vars))) | |
272 | (when bad-var | |
273 | (error "PS-ONLY-ONCE expected a non-keyword symbol but got ~s" bad-var)))) | |
274 | ||
275 | (defmacro ps-once-only ((&rest vars) &body body) | |
276 | (%check-once-only-vars vars) | |
277 | (let ((gensyms (mapcar (lambda (x) (ps-gensym (string x))) vars))) | |
278 | `(let ,(mapcar (lambda (g v) `(,g (ps-gensym ,(string v)))) gensyms vars) | |
279 | `(let* (,,@(mapcar (lambda (g v) ``(,,g ,,v)) gensyms vars)) | |
280 | ,(let ,(mapcar (lambda (g v) `(,v ,g)) gensyms vars) | |
281 | ,@body))))) |