Commit | Line | Data |
---|---|---|
cc4f1551 RD |
1 | (in-package :parenscript) |
2 | ||
9da682ca RD |
3 | ;;;; The mechanisms for defining macros & parsing Parenscript. |
4 | ||
171bbab3 RD |
5 | (eval-when (:compile-toplevel :load-toplevel) |
6 | (defun macro-name-hash-function () | |
905f534e | 7 | #'eql)) |
46f794a4 | 8 | |
9da682ca RD |
9 | (defclass script-package () |
10 | ;; configuration slots | |
11 | ((name :accessor script-package-name :initform nil :initarg :name :type string | |
12 | :documentation "Canonical name of the package (a String).") | |
13 | (nicknames :accessor script-package-nicknames :initform nil :initarg :nicknames | |
14 | :documentation "List of nicknames for the package (as strings).") | |
905f534e VS |
15 | (prefix :accessor script-package-prefix :initform nil :initarg :prefix :type string |
16 | :documentation "The prefix string that will be used when translating the symbols in the current package to Javascript.") | |
9da682ca RD |
17 | (lisp-package :accessor script-package-lisp-package :initform nil :initarg :lisp-package) |
18 | (secondary-lisp-packages :accessor script-package-secondary-lisp-packages :initform nil | |
19 | :initarg :secondary-lisp-packages) | |
5aa10005 RD |
20 | (exports :accessor script-package-exports :initarg :exports |
21 | :initform nil;(make-hash-table :test #'equal) | |
9da682ca RD |
22 | :documentation "List of exported identifiers.") |
23 | (used-packages :accessor script-package-used-packages :initform nil :initarg :used-packages | |
24 | :documentation "") | |
25 | (documentation :accessor script-package-documentation :initform nil :initarg :documentation) | |
26 | (compilation-env :accessor script-package-comp-env :initform nil :initarg :comp-env) | |
27 | (locked? :accessor script-package-locked? :initform nil :initarg :locked? | |
28 | :documentation "t if redefinition of top-level symbols is disallowed.") | |
29 | ;; internal use slots | |
46f794a4 RD |
30 | (symbol-table :accessor script-package-symbol-table :initform nil :initarg :symbol-table |
31 | :documentation "Contains symbols when there is no lisp package for this package.") | |
a98e58ee | 32 | ) |
9da682ca | 33 | (:documentation "A Parenscript package is a lisp object that holds information |
171bbab3 RD |
34 | about a set of code. |
35 | ||
36 | ")) | |
9da682ca RD |
37 | |
38 | (defclass compilation-environment () | |
39 | ((script-packages :accessor comp-env-script-packages :initform nil :initarg :packages | |
40 | :documentation "List of packages defined in this environment.") | |
41 | (current-package :accessor comp-env-current-package :initform nil :initarg :current-package | |
42 | :documentation "Current in-package.") | |
43 | (lisp-to-script-package-table | |
44 | :accessor comp-env-lisp-to-script-package-table :initform (make-hash-table) | |
a98e58ee RD |
45 | :documentation "Maps a lisp package to a script package.") |
46 | (compiling-toplevel-p | |
47 | :accessor comp-env-compiling-toplevel-p :initform nil :initarg :processing-toplevel-p | |
46f794a4 RD |
48 | :documentation "T if the environment is currently processing toplevel forms.") |
49 | (symbol-table :accessor symbol-to-script-package :initform (make-hash-table) | |
50 | :documentation "Maps symbols to script packages. Used for only the | |
51 | symbols in script packages that do not have a primary lisp package.")) | |
9da682ca RD |
52 | (:documentation "")) |
53 | ||
46f794a4 RD |
54 | (defgeneric symbol-script-package (symbol) |
55 | (:documentation "Gets the Parenscript package associated with a Lisp/Parenscript symbol.")) | |
56 | ||
a98e58ee RD |
57 | (defgeneric compiler-in-situation-p (comp-env situation) |
58 | (:documentation "Returns true when the compiler is considered 'in' the situation | |
5aa10005 | 59 | given by SITUATION, which is one of :compile-toplevel :execute.") |
a98e58ee RD |
60 | (:method ((comp-env compilation-environment) situation) |
61 | (cond | |
62 | ((eql situation :compile-toplevel) (processing-toplevel-p comp-env)) | |
63 | ((eql situation :execute) (not (processing-toplevel-p comp-env))) | |
64 | (t nil)))) | |
65 | ||
66 | (defgeneric processing-toplevel-p (comp-env) | |
67 | (:documentation "T if we are compiling TOPLEVEL forms, as in | |
68 | http://www.lispworks.com/documentation/HyperSpec/Body/03_bca.htm") | |
69 | (:method ((comp-env compilation-environment)) | |
70 | (comp-env-compiling-toplevel-p comp-env) | |
71 | )) | |
72 | ||
e9ad96ee | 73 | (defvar *compilation-environment* nil |
5aa10005 RD |
74 | "The active compilation environment." |
75 | ;; Right now all code assumes that *compilation-environment* is accurately bound to the | |
76 | ;; current compilation environment--even some functions that take the compilation environment | |
77 | ;; as arguments. | |
78 | ) | |
79 | ||
5aa10005 RD |
80 | (defvar *package-prefix-style* :prefix |
81 | "Determines how package symbols are serialized to JavaScript identifiers. NIL for | |
82 | no prefixes. :prefix to prefix variables with something like packagename_identifier.") | |
9da682ca | 83 | |
905f534e VS |
84 | (defvar *warn-ps-package* nil |
85 | "If true, warns when ParenScript attempts to compile symbols that | |
86 | don't have an associated ParenScript package.") | |
87 | ||
9da682ca RD |
88 | ;;; parenscript packages |
89 | (defun lisp-to-script-package (lisp-package &optional (comp-env *compilation-environment*)) | |
90 | "Gets a script package corresponding to the given Lisp package." | |
91 | (gethash lisp-package (comp-env-lisp-to-script-package-table comp-env))) | |
92 | ||
93 | (defsetf lisp-to-script-package (lisp-package &optional (comp-env *compilation-environment*)) | |
94 | (script-package) | |
95 | "Sets the script package corresponding to the given Lisp package." | |
96 | `(setf (gethash ,lisp-package (comp-env-lisp-to-script-package-table ,comp-env)) | |
97 | ,script-package)) | |
98 | ||
46f794a4 RD |
99 | (defmethod symbol-script-package ((symbol symbol)) |
100 | (if (symbol-package symbol) | |
905f534e VS |
101 | (or (lisp-to-script-package (symbol-package symbol) *compilation-environment*) |
102 | (progn (when *warn-ps-package* | |
103 | (warn 'simple-style-warning | |
104 | :format-control "~s is a symbol with lisp package ~s, which has no corresponding ParenScript package. | |
105 | Defaulting to :parenscript-user." | |
106 | :format-arguments (list symbol (symbol-package symbol)))) | |
107 | (find-script-package "PARENSCRIPT-USER" (make-basic-compilation-environment)))) | |
8723dc34 | 108 | (find-script-package "UNINTERNED" *compilation-environment*))) |
9da682ca RD |
109 | |
110 | (defun find-script-package (name &optional (comp-env *compilation-environment*)) | |
111 | "Find the script package with the name NAME in the given compilation environment." | |
5aa10005 RD |
112 | (typecase name |
113 | ((or symbol string) | |
171bbab3 RD |
114 | (find-if #'(lambda (script-package) |
115 | (find (string name) | |
116 | (cons (script-package-name script-package) | |
117 | (script-package-nicknames script-package)) | |
118 | :test #'equal)) | |
119 | (comp-env-script-packages comp-env))) | |
905f534e | 120 | (script-package name) |
5aa10005 RD |
121 | (t (error "~A has unknown type" name)))) |
122 | ||
905f534e | 123 | (defun script-intern (name script-package-name) |
5aa10005 RD |
124 | "Returns a Parenscript symbol with the string value STRING interned for the |
125 | given SCRIPT-PACKAGE." | |
46f794a4 | 126 | (declare (type string name)) |
905f534e VS |
127 | (let ((script-package (find-script-package script-package-name))) |
128 | (flet ((find-exported-symbol (name script-package) | |
129 | (let ((res | |
130 | (find name (script-package-exports script-package) | |
131 | :key #'(lambda (exported-symbol) (string exported-symbol)) | |
132 | :test #'equal))) | |
133 | res))) | |
134 | (let ((res | |
135 | (or | |
136 | (some #'(lambda (used-package) | |
137 | (find-exported-symbol name used-package)) | |
138 | (script-package-used-packages script-package)) | |
139 | (if (script-package-lisp-package script-package) | |
140 | (intern name (script-package-lisp-package script-package)) | |
141 | (progn | |
142 | (let ((sym (intern-without-package name))) | |
143 | (setf (gethash name (script-package-symbol-table script-package)) | |
144 | sym) | |
145 | (setf (gethash sym (symbol-to-script-package (script-package-comp-env script-package))) | |
146 | script-package) | |
147 | sym)))))) | |
148 | (declare (type symbol res)) | |
149 | res)))) | |
171bbab3 | 150 | |
5aa10005 RD |
151 | (defun find-script-symbol (name script-package) |
152 | "Finds the symbol with name NAME in the script package SCRIPT-PACKAGE. NAME is a | |
153 | string and SCRIPT-PACKAGE is a package designator. If NAME does not specify a symbol of | |
154 | script-package, returns nil. Otherwise returns 2 values: | |
155 | 1. the symbol | |
bbea4c83 RD |
156 | 2. :external if the symbol is external. :internal if the symbol is internal. NIL if |
157 | the symbol is not interned in the package." | |
5aa10005 | 158 | (setf script-package (find-script-package script-package)) |
bbea4c83 RD |
159 | (let (symbol interned-p) |
160 | ||
161 | (if (script-package-lisp-package script-package) | |
162 | (multiple-value-bind (lisp-symbol lisp-status) | |
163 | (find-symbol name (script-package-lisp-package script-package)) | |
164 | (setf symbol lisp-symbol) | |
165 | (setf interned-p (and lisp-status t))) | |
166 | (multiple-value-bind (sym sym-found-p) | |
167 | (gethash name (script-package-symbol-table script-package)) | |
168 | (setf symbol sym) | |
169 | (setf interned-p sym-found-p))) | |
170 | (let ((exported? (member symbol (script-package-exports script-package)))) | |
171 | (values symbol | |
172 | (if exported? :external (if interned-p :internal nil)))))) | |
5aa10005 | 173 | |
171bbab3 RD |
174 | (defun script-export (symbols |
175 | &optional (script-package (comp-env-current-package *compilation-environment*))) | |
176 | "Exports the given symbols in the given script package." | |
177 | (when (not (listp symbols)) (setf symbols (list symbols))) | |
178 | (setf script-package (find-script-package script-package)) | |
171bbab3 RD |
179 | (let ((symbols-not-in-package |
180 | (remove-if #'(lambda (symbol) | |
181 | (declare (type symbol symbol)) | |
182 | (eql symbol (find-script-symbol (string symbol) script-package))) | |
183 | symbols))) | |
184 | (when symbols-not-in-package | |
185 | (error "Invalid exports. The following symbols are not interned in the package ~A:~%~A" | |
186 | (script-package-name script-package) symbols-not-in-package))) | |
187 | (mapc #'(lambda (symbol) | |
188 | (pushnew symbol (script-package-exports script-package))) | |
189 | symbols) | |
190 | t) | |
191 | ||
192 | (defun use-script-package (packages-to-use | |
193 | &optional (into-package (comp-env-current-package *compilation-environment*))) | |
194 | "use-script-package causes INTO-PACKAGE to inherit all the external symbols of packages-to-use. | |
195 | The inherited symbols become accessible as internal symbols of package." | |
196 | (when (not (listp packages-to-use)) (setf packages-to-use (list packages-to-use))) | |
197 | (setf packages-to-use (mapcar #'find-script-package packages-to-use)) | |
198 | (setf into-package (find-script-package into-package)) | |
199 | ||
200 | (let ((all-used-symbols (apply #'append (mapcar #'script-package-exports packages-to-use)))) | |
201 | (mapc #'(lambda (used-symbol) | |
202 | (let ((symbol-same-name (find-script-symbol (string used-symbol) into-package))) | |
203 | (when (not (or (null symbol-same-name) | |
204 | (eql symbol-same-name used-symbol))) | |
205 | (error "Import of symbol ~A into package ~A conflicts with interned symbol ~A" | |
206 | used-symbol (script-package-name into-package) symbol-same-name)))) | |
207 | all-used-symbols)) | |
208 | (setf (script-package-used-packages into-package) | |
209 | (append (script-package-used-packages into-package) packages-to-use))) | |
210 | ||
5aa10005 | 211 | |
171bbab3 RD |
212 | |
213 | ;; environmental considerations | |
5aa10005 RD |
214 | (defgeneric setup-compilation-environment (comp-env) |
215 | (:documentation "Sets up a basic compilation environment prepared for a language user. | |
216 | This should do things like define packages and set the current package. | |
217 | ||
171bbab3 RD |
218 | Returns the compilation-environment.")) |
219 | ||
220 | (defgeneric install-standard-script-packages (comp-env) | |
221 | (:documentation "Creates standard script packages and installs them in the current compilation | |
222 | environment.")) | |
5aa10005 | 223 | |
9da682ca RD |
224 | (defun make-basic-compilation-environment () |
225 | "Creates a compilation environment object from scratch. Fills it in with the default | |
226 | script packages (parenscript, global, and parenscript-user)." | |
171bbab3 RD |
227 | (let ((*compilation-environment* (make-instance 'compilation-environment))) |
228 | (setup-compilation-environment *compilation-environment*))) | |
9da682ca | 229 | |
46f794a4 RD |
230 | (defun intern-without-package (name) |
231 | (macrolet ((with-temp-package ((var) &body body) | |
232 | (let ((result-var (gensym))) | |
233 | `(let* ((,var (make-package ',(gensym))) | |
234 | (,result-var (progn ,@body))) | |
235 | (delete-package ,var) | |
236 | ,result-var)))) | |
237 | (with-temp-package (package) | |
238 | (let ((sym (intern name package))) | |
239 | (unintern sym package) | |
240 | sym)))) | |
241 | ||
242 | ||
243 | ||
9da682ca | 244 | (defun create-script-package (comp-env |
905f534e | 245 | &key name nicknames prefix secondary-lisp-packages used-packages |
9da682ca RD |
246 | lisp-package exports documentation) |
247 | "Creates a script package in the given compilation environment" | |
46f794a4 RD |
248 | (when (and lisp-package (not (find-package lisp-package))) |
249 | (error "Package ~A does not exists" lisp-package)) | |
250 | (let* ((script-package | |
251 | (make-instance 'script-package | |
252 | :name (string name) | |
253 | :comp-env comp-env | |
905f534e | 254 | :prefix prefix |
46f794a4 RD |
255 | :nicknames (mapcar #'string nicknames) |
256 | :lisp-package (when lisp-package (find-package lisp-package)) | |
257 | :secondary-lisp-packages (mapcar #'find-package secondary-lisp-packages) | |
258 | :documentation documentation))) | |
259 | (use-script-package used-packages script-package) | |
260 | (labels ((package-intern (string-like) | |
261 | (script-intern (string string-like) script-package))) | |
262 | (script-export (mapcar #'package-intern exports) script-package)) | |
263 | (push script-package (comp-env-script-packages comp-env)) | |
264 | script-package)) | |
9da682ca RD |
265 | |
266 | (defmethod initialize-instance :after ((package script-package) &key) | |
267 | (assert (script-package-comp-env package)) | |
46f794a4 RD |
268 | (when (null (script-package-lisp-package package)) |
269 | (setf (script-package-symbol-table package) | |
270 | (make-hash-table :test #'equal))) | |
271 | (let ((lisp-packages | |
272 | (remove-if #'null | |
273 | (cons (script-package-lisp-package package) | |
274 | (script-package-secondary-lisp-packages package))))) | |
9da682ca RD |
275 | (dolist (lisp-package lisp-packages) |
276 | (when (lisp-to-script-package lisp-package (script-package-comp-env package)) | |
dc20626d | 277 | (error "Lisp package already has corresponding script package: ~A" (package-name lisp-package))) |
9da682ca RD |
278 | (setf (lisp-to-script-package lisp-package (script-package-comp-env package)) |
279 | package)))) | |
280 | ||
281 | (defgeneric comp-env-find-package (comp-env package-designator) | |
282 | (:documentation "Finds the script package named by PACKAGE-DESIGNATOR in the current | |
283 | compilation environment. PACKAGE-DESIGNATOR is a string or symbol.") | |
284 | (:method ((comp-env compilation-environment) (name string)) | |
285 | (find name (comp-env-script-packages comp-env) | |
286 | :key #'script-package-name :test #'equal)) | |
287 | (:method ((comp-env compilation-environment) (package-designator symbol)) | |
288 | (comp-env-find-package comp-env (string package-designator)))) | |
289 | ||
290 | ;; TODO loop through all defined macros and add them to the script package's | |
291 | ;; macro environment | |
292 | ; (labels ((name-member (name) | |
293 | ; (eql (script-package-lisp-package script-package) (symbol-package name))) | |
294 | ; (import-macro (name function) | |
295 | ; (when (name-member name) | |
296 | ; (setf (gethash name (script-package-macro-table script-package)) | |
297 | ; function))) | |
298 | ; (import-special-form (name function) | |
299 | ; (when (name-member name) | |
300 | ; (setf (gethash name (script-package-special-form-table script-package)) | |
301 | ; function)))) | |
302 | ; (maphash #'import-special-form *toplevel-special-forms*) | |
303 | ; (maphash #'import-special-form *toplevel-special-forms*) | |
304 | ||
305 | ;(defgeneric comp-env-select-package (comp-env script-package) | |
306 | ; (:documentation "") | |
307 | ; (:method ((comp-env compilation-environment) (package script-package)) | |
308 | ; (setf (comp-env-current-package | |
309 | ||
cc4f1551 RD |
310 | |
311 | (eval-when (:compile-toplevel :load-toplevel :execute) | |
171bbab3 | 312 | (defvar *toplevel-special-forms* (make-hash-table :test (macro-name-hash-function)) |
9da682ca RD |
313 | "A hash-table containing functions that implement Parenscript special forms, |
314 | indexed by name (as symbols)") | |
9da682ca RD |
315 | (defun undefine-script-special-form (name) |
316 | "Undefines the special form with the given name (name is a symbol)." | |
317 | (declare (type symbol name)) | |
318 | (when (gethash name *toplevel-special-forms*) | |
319 | (remhash name *toplevel-special-forms*)))) | |
cc4f1551 | 320 | |
9da682ca | 321 | (defmacro define-script-special-form (name lambda-list &rest body) |
cc4f1551 | 322 | "Define a special form NAME. Arguments are destructured according to |
9da682ca | 323 | LAMBDA-LIST. The resulting Parenscript language types are appended to the |
cc4f1551 | 324 | ongoing javascript compilation." |
9da682ca RD |
325 | (declare (type symbol name)) |
326 | (let ((script-name | |
327 | (intern (format nil "PAREN-~A" (symbol-name name)) | |
328 | (find-package :parenscript))) | |
329 | (arglist (gensym "ps-arglist-"))) | |
171bbab3 RD |
330 | `(setf (gethash (quote ,name) *toplevel-special-forms*) |
331 | #'(lambda (&rest ,arglist) | |
332 | (destructuring-bind ,lambda-list | |
333 | ,arglist | |
334 | ,@body))))) | |
335 | ||
9da682ca RD |
336 | |
337 | (defun get-script-special-form (name) | |
338 | "Returns the special form function corresponding to the given name." | |
905f534e VS |
339 | (when (symbolp name) |
340 | (gethash name *toplevel-special-forms*))) | |
cc4f1551 | 341 | |
9da682ca RD |
342 | ;;; sexp form predicates |
343 | (defun script-special-form-p (form) | |
344 | "Returns T if FORM is a special form and NIL otherwise." | |
cc4f1551 RD |
345 | (and (consp form) |
346 | (symbolp (car form)) | |
171bbab3 | 347 | (get-script-special-form (car form)))) |
cc4f1551 | 348 | |
9da682ca RD |
349 | (defun funcall-form-p (form) |
350 | (and (listp form) | |
5aa10005 | 351 | (not (ps-js::op-form-p form)) |
9da682ca | 352 | (not (script-special-form-p form)))) |
cc4f1551 | 353 | |
9da682ca RD |
354 | (defun method-call-p (form) |
355 | (and (funcall-form-p form) | |
356 | (symbolp (first form)) | |
357 | (eql (char (symbol-name (first form)) 0) #\.))) | |
cc4f1551 | 358 | |
9da682ca | 359 | ;;; macro expansion |
cc4f1551 RD |
360 | (eval-when (:compile-toplevel :load-toplevel :execute) |
361 | (defun make-macro-env-dictionary () | |
9da682ca | 362 | "Creates a standard macro dictionary." |
72332f2a | 363 | (make-hash-table :test (macro-name-hash-function))) |
9da682ca | 364 | (defvar *script-macro-toplevel* (make-macro-env-dictionary) |
72332f2a VS |
365 | "Toplevel macro environment dictionary. Key is the symbol of the |
366 | macro, value is (symbol-macro-p . expansion-function).") | |
9da682ca | 367 | (defvar *script-macro-env* (list *script-macro-toplevel*) ;(list nil) |
171bbab3 | 368 | "Current macro environment.") |
72332f2a VS |
369 | |
370 | (defvar *script-setf-expanders* (make-macro-env-dictionary) | |
371 | "Setf expander dictionary. Key is the symbol of the access | |
372 | function of the place, value is an expansion function that takes the | |
373 | arguments of the access functions as a first value and the form to be | |
374 | stored as the second value.") | |
171bbab3 RD |
375 | |
376 | (defun find-macro-spec (name env-dict) | |
905f534e | 377 | (gethash name env-dict)) |
171bbab3 RD |
378 | (defsetf find-macro-spec (name env-dict) |
379 | (spec) | |
380 | `(setf (gethash ,name ,env-dict) ,spec))) | |
381 | ||
cc4f1551 RD |
382 | |
383 | (defmacro get-macro-spec (name env-dict) | |
9da682ca | 384 | "Retrieves the macro spec of the given name with the given environment dictionary. |
72332f2a | 385 | SPEC is of the form (symbol-macro-p . expansion-function)." |
171bbab3 | 386 | `(find-macro-spec ,name ,env-dict)) |
9da682ca RD |
387 | |
388 | (defun lookup-macro-spec (name &optional (environment *script-macro-env*)) | |
389 | "Looks up the macro spec associated with NAME in the given environment. A | |
905f534e | 390 | macro spec is of the form (symbol-macro-p . function). Returns two values: |
9da682ca | 391 | the SPEC and the parent macro environment. |
cc4f1551 | 392 | |
9da682ca | 393 | NAME must be a symbol." |
cc4f1551 RD |
394 | (when (symbolp name) |
395 | (do ((env environment (cdr env))) | |
396 | ((null env) nil) | |
397 | (let ((val (get-macro-spec name (car env)))) | |
398 | (when val | |
399 | (return-from lookup-macro-spec | |
400 | (values val (or (cdr env) | |
9da682ca | 401 | (list *script-macro-toplevel*))))))))) |
cc4f1551 | 402 | |
9da682ca RD |
403 | (defun script-symbol-macro-p (name &optional (environment *script-macro-env*)) |
404 | "True if there is a Parenscript symbol macro named by the symbol NAME." | |
cc4f1551 RD |
405 | (and (symbolp name) (car (lookup-macro-spec name environment)))) |
406 | ||
9da682ca RD |
407 | (defun script-macro-p (name &optional (environment *script-macro-env*)) |
408 | "True if there is a Parenscript macro named by the symbol NAME." | |
409 | (and (symbolp name) | |
410 | (let ((macro-spec (lookup-macro-spec name environment))) | |
411 | (and macro-spec (not (car macro-spec)))))) | |
cc4f1551 | 412 | |
9da682ca | 413 | (defun lookup-macro-expansion-function (name &optional (environment *script-macro-env*)) |
cc4f1551 RD |
414 | "Lookup NAME in the given macro expansion environment (which |
415 | defaults to the current macro environment). Returns the expansion | |
416 | function and the parent macro environment of the macro." | |
417 | (multiple-value-bind (macro-spec parent-env) | |
418 | (lookup-macro-spec name environment) | |
419 | (values (cdr macro-spec) parent-env))) | |
420 | ||
9da682ca RD |
421 | (defmacro defscriptmacro (name args &body body) |
422 | "Define a ParenScript macro, and store it in the toplevel ParenScript | |
423 | macro environment." | |
cc4f1551 | 424 | (let ((lambda-list (gensym "ps-lambda-list-")) |
0b37e317 | 425 | (body (if (and (cdr body) (stringp (first body))) (rest body) body))) ;; drop docstring |
9da682ca RD |
426 | (undefine-script-special-form name) |
427 | `(setf (get-macro-spec ',name *script-macro-toplevel*) | |
cc4f1551 RD |
428 | (cons nil (lambda (&rest ,lambda-list) |
429 | (destructuring-bind ,args | |
430 | ,lambda-list | |
431 | ,@body)))))) | |
432 | ||
46f794a4 | 433 | (defmacro define-script-symbol-macro (name &body body) |
b5369cb1 | 434 | "Define a ParenScript symbol macro, and store it in the toplevel ParenScript |
46f794a4 RD |
435 | macro environment. BODY is a Lisp form that should return a ParenScript form." |
436 | (let ((body (if (and (cdr body) (stringp (first body))) (rest body) body))) ;; drop docstring | |
437 | (undefine-script-special-form name) | |
438 | `(setf (get-macro-spec ',name *script-macro-toplevel*) | |
439 | (cons t (lambda () ,@body))))) | |
b5369cb1 | 440 | |
7590646c VS |
441 | (defun import-macros-from-lisp (&rest names) |
442 | "Import the named Lisp macros into the ParenScript macro | |
443 | environment. When the imported macro is macroexpanded by ParenScript, | |
444 | it is first fully macroexpanded in the Lisp macro environment, and | |
445 | then that expansion is further expanded by ParenScript." | |
446 | (dolist (name names) | |
447 | (let ((name name)) | |
448 | (undefine-script-special-form name) | |
449 | (setf (get-macro-spec name *script-macro-toplevel*) | |
450 | (cons nil (lambda (&rest args) | |
451 | (macroexpand `(,name ,@args)))))))) | |
452 | ||
f016e033 | 453 | (defmacro defmacro/ps (name args &body body) |
7590646c VS |
454 | "Define a Lisp macro and import it into the ParenScript macro environment." |
455 | `(progn (defmacro ,name ,args ,@body) | |
f016e033 | 456 | (ps:import-macros-from-lisp ',name))) |
7590646c | 457 | |
f016e033 | 458 | (defmacro defmacro+ps (name args &body body) |
7590646c VS |
459 | "Define a Lisp macro and a ParenScript macro in their respective |
460 | macro environments. This function should be used when you want to use | |
461 | the same macro in both Lisp and ParenScript, but the 'macroexpand' of | |
462 | that macro in Lisp makes the Lisp macro unsuitable to be imported into | |
463 | the ParenScript macro environment." | |
464 | `(progn (defmacro ,name ,args ,@body) | |
465 | (defscriptmacro ,name ,args ,@body))) | |
466 | ||
467 | (defmacro defpsmacro (&rest args) | |
468 | `(defscriptmacro ,@args)) | |
9da682ca RD |
469 | |
470 | (defun expand-script-form (expr) | |
46f794a4 RD |
471 | "Expands a Parenscript form until it reaches a special form. Returns 2 values: |
472 | 1. the expanded form. | |
473 | 2. whether the form was expanded." | |
cc4f1551 RD |
474 | (if (consp expr) |
475 | (let ((op (car expr)) | |
476 | (args (cdr expr))) | |
46f794a4 RD |
477 | (cond ((equal op 'quote) |
478 | (values | |
479 | (if (equalp '(nil) args) nil expr) ;; leave quotes alone, unless it's a quoted nil | |
480 | nil)) | |
9da682ca RD |
481 | ((script-macro-p op) ;; recursively expand parenscript macros in parent env. |
482 | (multiple-value-bind (expansion-function macro-env) | |
483 | (lookup-macro-expansion-function op) | |
46f794a4 RD |
484 | (values |
485 | (expand-script-form (let ((*script-macro-env* macro-env)) | |
486 | (apply expansion-function args))) | |
487 | t))) | |
488 | (t (values expr nil)))) | |
9da682ca RD |
489 | ;; not a cons |
490 | (cond ((script-special-form-p expr) | |
491 | ;; leave special forms alone (expanded during compile) | |
46f794a4 | 492 | (values expr nil)) |
9da682ca RD |
493 | ((script-symbol-macro-p expr) |
494 | ;; recursively expand symbol macros in parent env. | |
495 | (multiple-value-bind (expansion-function macro-env) | |
496 | (lookup-macro-expansion-function expr) | |
46f794a4 RD |
497 | (values |
498 | (expand-script-form (let ((*script-macro-env* macro-env)) | |
499 | (funcall expansion-function))) | |
500 | t))) | |
9da682ca | 501 | ;; leave anything else alone |
46f794a4 | 502 | (t (values expr nil))))) |
cc4f1551 | 503 | |
a98e58ee RD |
504 | (defun process-eval-when-args (args) |
505 | "(eval-when form-language? (situation*) form*) - returns 3 values: | |
506 | form-language, a list of situations, and a list of body forms" | |
507 | (let* ((rest args) | |
508 | (form-language | |
509 | (when (not (listp (first rest))) | |
510 | (setf rest (rest args)) | |
511 | (first args))) | |
512 | (situations (first rest)) | |
513 | (body (rest rest))) | |
514 | (when (and (find :compile-toplevel situations) (find :execute situations)) | |
515 | (error "Cannot use EVAL-WHEN to execute COMPILE-TOPLEVEL and EXECUTE code simultaneously.")) | |
516 | (when (null form-language) | |
517 | (setf form-language | |
518 | (cond | |
519 | ((find :compile-toplevel situations) :lisp) | |
520 | ((find :execute situations) :parenscript)))) | |
521 | (values form-language situations body))) | |
522 | ||
cc4f1551 | 523 | ;;;; compiler interface ;;;; |
46f794a4 | 524 | (defgeneric compile-parenscript-form (compilation-environment form) |
a98e58ee RD |
525 | (:documentation "Compiles FORM, which is a ParenScript form. |
526 | If toplevel-p is NIL, the result is a compilation object (the AST root). | |
527 | Subsequently TRANSLATE-AST can be called to convert the result to Javascript. | |
528 | ||
529 | If the compiler is in the COMPILE-TOPLEVEL stage, then the result will | |
530 | be a Parenscript form (after it has been processed according to semantics | |
531 | like those of Lisp's COMPILE-FILE). See | |
532 | http://www.lispworks.com/documentation/HyperSpec/Body/03_bca.htm")) | |
9da682ca | 533 | |
46f794a4 RD |
534 | (defgeneric compile-toplevel-parenscript-form (comp-env form) |
535 | (:documentation "Compiles a parenscript form in the given compilation environment | |
536 | when the environment is in the :compile-toplevel situation. Returns a form to be | |
537 | compiled in place of the original form upon exiting the :compile-toplevel situation.")) | |
538 | ||
539 | (defmethod compile-toplevel-parenscript-form ((comp-env compilation-environment) form) | |
540 | (cond | |
541 | ((not (listp form)) form) | |
542 | ;; process each clause of a progn as a toplevel form | |
543 | ((eql 'progn (car form)) | |
544 | `(progn | |
545 | ,@(mapcar #'(lambda (subform) | |
546 | (compile-parenscript-form comp-env subform)) | |
547 | (rest form)))) | |
548 | ;; TODO process macrolets, symbol-macrolets, and file inclusions | |
549 | ||
550 | ;; process eval-when. evaluates in :COMPILE-TOPLEVEL situation and returns | |
551 | ;; the resultant form. for :EXECUTE situation it returns | |
552 | ((eql 'eval-when (car form)) | |
553 | (multiple-value-bind (body-language situations body) | |
554 | (process-eval-when-args (rest form)) | |
555 | (cond | |
556 | ((find :compile-toplevel situations) | |
557 | (when (eql body-language :lisp) | |
558 | (let ((other-situations (remove :compile-toplevel situations))) | |
559 | (multiple-value-bind (function warnings-p failure-p) | |
560 | (compile nil `(lambda () ,@body)) | |
561 | (declare (ignore warnings-p) (ignore failure-p)) | |
562 | (compile-parenscript-form | |
563 | comp-env | |
564 | `(progn | |
565 | ,(funcall function) | |
566 | ,@(when other-situations | |
567 | (list `(eval-when ,other-situations ,@body))))))))) | |
568 | ;; if :compile-toplevel is not in the situation list, return the form | |
569 | (t form)))) | |
570 | (t form))) | |
571 | ||
572 | ||
573 | (defmethod compile-parenscript-form :around ((comp-env compilation-environment) form) | |
574 | (multiple-value-bind (expanded-form expanded-p) | |
575 | (expand-script-form form) | |
576 | (cond | |
577 | (expanded-p | |
578 | (compile-parenscript-form comp-env expanded-form)) | |
579 | ((comp-env-compiling-toplevel-p comp-env) | |
580 | (compile-toplevel-parenscript-form comp-env form)) | |
581 | (t (call-next-method))))) | |
582 | ||
583 | (defmethod compile-parenscript-form ((comp-env compilation-environment) (form string)) | |
584 | (make-instance 'ps-js::string-literal :value form)) | |
585 | ||
586 | (defmethod compile-parenscript-form ((comp-env compilation-environment) (form character)) | |
587 | (compile-parenscript-form comp-env (string form))) | |
588 | ||
589 | (defmethod compile-parenscript-form ((comp-env compilation-environment) (form number)) | |
590 | (make-instance 'ps-js::number-literal :value form)) | |
591 | ||
592 | (defmethod compile-parenscript-form ((comp-env compilation-environment) (form symbol)) | |
593 | ;; is this the correct behavior? | |
594 | (let ((c-macro (get-script-special-form form))) | |
595 | (cond | |
596 | (c-macro (funcall c-macro)) | |
597 | ;; the following emulates the lisp behavior that a keyword is bound to itself | |
598 | ;; see http://clhs.lisp.se/Body/t_kwd.htm | |
599 | ((keywordp form) (compile-parenscript-form comp-env `(quote ,form))) | |
600 | (t (make-instance 'ps-js::js-variable :value form))))) | |
601 | ||
602 | (defun compile-function-argument-forms (forms) | |
603 | "Compiles a bunch of Parenscript forms from a funcall form to an effective set of | |
604 | Javascript arguments. The only extra processing this does is makes :keyword arguments | |
605 | into a single options argument via CREATE." | |
606 | (flet ((keyword-arg (arg) | |
607 | "If the given compiled expression is supposed to be a keyword argument, returns | |
608 | the keyword for it." | |
609 | (when (typep arg 'script-quote) (ps-js::value arg)))) | |
610 | (let ((expressions (mapcar #'compile-to-expression forms))) | |
611 | ||
612 | (do ((effective-expressions nil) | |
613 | (expressions-subl expressions)) | |
614 | ||
615 | ((not expressions-subl) | |
616 | (nreverse effective-expressions)) | |
617 | ||
618 | (let ((arg-expr (first expressions-subl))) | |
619 | (if (keyword-arg arg-expr) | |
620 | (progn | |
621 | (when (oddp (length expressions-subl)) | |
622 | (error "Odd number of keyword arguments.")) | |
623 | (push | |
624 | (make-instance 'ps-js::js-object | |
625 | :slots | |
626 | (loop for (name val) on expressions-subl by #'cddr | |
627 | collect (list name val))) | |
628 | effective-expressions) | |
629 | (setf expressions-subl nil)) | |
630 | (progn | |
631 | (push arg-expr effective-expressions) | |
632 | (setf expressions-subl (rest expressions-subl))))))))) | |
633 | ||
634 | (defmethod compile-parenscript-form ((comp-env compilation-environment) (form cons)) | |
635 | (let* ((name (car form)) | |
636 | (args (cdr form)) | |
637 | (script-form (get-script-special-form name))) | |
638 | (cond | |
639 | ((eql name 'quote) (make-instance 'script-quote :value (first args))) | |
640 | (script-form (apply script-form args)) | |
641 | ((ps-js::op-form-p form) | |
642 | (make-instance 'ps-js::op-form | |
643 | :operator (ps-js::script-convert-op-name (compile-to-symbol (first form))) | |
644 | :args (mapcar #'compile-to-expression (rest form)))) | |
645 | ((method-call-p form) | |
646 | (make-instance 'ps-js::method-call | |
647 | :method (compile-to-symbol name) | |
648 | :object (compile-to-expression (first args)) | |
649 | :args (compile-function-argument-forms (rest args)))) | |
650 | ((funcall-form-p form) | |
651 | (make-instance 'ps-js::function-call | |
652 | :function (compile-to-expression name) | |
653 | :args (compile-function-argument-forms args))) | |
654 | (t (error "Unknown form ~S" form))))) | |
cc4f1551 | 655 | |
9da682ca RD |
656 | (defun compile-script-form (form &key (comp-env *compilation-environment*)) |
657 | "Compiles a Parenscript form to an AST node." | |
727a0288 | 658 | (compile-parenscript-form comp-env form)) |
9da682ca RD |
659 | |
660 | (defun compile-to-expression (form) | |
661 | "Compiles the given Parenscript form and guarantees the result is an expression." | |
662 | (let ((res (compile-script-form form))) | |
5aa10005 | 663 | (assert (typep res 'ps-js::expression)) |
cc4f1551 RD |
664 | res)) |
665 | ||
9da682ca | 666 | (defun compile-to-symbol (form) |
5aa10005 RD |
667 | "Compiles the given Parenscript form and guarantees a symbolic result. This |
668 | also guarantees that the symbol has an associated script-package." | |
9da682ca | 669 | (let ((res (compile-script-form form))) |
5aa10005 RD |
670 | (when (typep res 'ps-js::js-variable) |
671 | (setf res (ps-js::value res))) | |
bbea4c83 RD |
672 | (when (typep res 'ps-js::script-quote) |
673 | (setf res (ps-js::value res))) | |
30135005 | 674 | (assert (symbolp res) () |
905f534e | 675 | "~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 res form (ps::ps* form) form) |
8723dc34 VS |
676 | (unless (symbol-script-package res) |
677 | (when *warn-ps-package* | |
678 | (warn 'simple-style-warning | |
679 | :format-control "The symbol ~A::~A has no associated script package." | |
680 | :format-arguments (list (if (symbol-package res) (package-name (symbol-package res)) "ANONYMOUS-PACKAGE") | |
681 | res)))) | |
cc4f1551 RD |
682 | res)) |
683 | ||
9da682ca RD |
684 | (defun compile-to-statement (form) |
685 | "Compiles the given Parenscript form and guarantees the result is a statement." | |
686 | (let ((res (compile-script-form form))) | |
5aa10005 | 687 | (assert (typep res 'ps-js::statement)) |
cc4f1551 RD |
688 | res)) |
689 | ||
5aa10005 | 690 | (defun compile-to-block (form &key (indent "")) |
9da682ca RD |
691 | "Compiles the given Parenscript form and guarantees the result is of type SCRIPT-BODY" |
692 | (let ((res (compile-to-statement form))) | |
5aa10005 RD |
693 | (if (typep res 'ps-js::js-block) |
694 | (progn (setf (ps-js::block-indent res) indent) | |
cc4f1551 | 695 | res) |
5aa10005 | 696 | (make-instance 'ps-js::js-block |
cc4f1551 | 697 | :indent indent |
9da682ca | 698 | :statements (list res))))) |