1 (in-package "PARENSCRIPT")
3 ;;; reserved symbols/literals
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"
15 (defun add-ps-reserved-symbol (name)
16 (pushnew (symbol-name-to-js-string name
) *ps-reserved-symbol-names
* :test
#'equalp
))
18 (defun ps-reserved-symbol-p (symbol)
19 (when (symbolp symbol
)
20 (find (symbol-name-to-js-string symbol
) *ps-reserved-symbol-names
* :test
#'equalp
)))
24 (defvar *ps-special-forms
* (make-hash-table :test
'eq
))
26 (defun get-ps-special-form (name)
27 (gethash name
*ps-special-forms
*))
29 (defmacro define-ps-special-form
(name lambda-list
&rest body
)
30 `(setf (gethash ',name
*ps-special-forms
*)
32 (destructuring-bind ,lambda-list
36 (defun undefine-ps-special-form (name)
37 (remhash name
*ps-special-forms
*))
39 (defun ps-special-form-p (form)
42 (gethash (car form
) *ps-special-forms
*)))
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
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
53 enclosing special form to introduce the variable bindings in its
56 (defvar *ps-special-variables
* ())
58 (defun ps-special-variable-p (sym)
59 (member sym
*ps-special-variables
*))
63 (defun comparison-form-p (form)
64 (member (car form
) '(< > <= >= == != === !==)))
66 (defun op-form-p (form)
68 (not (ps-special-form-p form
))
69 (not (null (op-precedence (first form
))))))
71 (defun funcall-form-p (form)
74 (not (op-form-p form
))
75 (not (ps-special-form-p form
))))
78 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
79 (defun make-macro-dictionary ()
80 (make-hash-table :test
'eq
))
82 (defvar *ps-macro-toplevel
* (make-macro-dictionary)
83 "Toplevel macro environment dictionary.")
85 (defvar *ps-macro-env
* (list *ps-macro-toplevel
*)
86 "Current macro environment.")
88 (defvar *ps-symbol-macro-toplevel
* (make-macro-dictionary))
90 (defvar *ps-symbol-macro-env
* (list *ps-symbol-macro-toplevel
*))
92 (defvar *ps-local-function-names
* ())
94 (defvar *ps-setf-expanders
* (make-macro-dictionary)
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.")
100 (defparameter *ps-compilation-level
* :toplevel
101 "This value takes on the following values:
102 :toplevel indicates that we are traversing toplevel forms.
103 :inside-toplevel-form indicates that we are inside a call to ps-compile-*
104 nil indicates we are no longer toplevel-related."))
106 (defun lookup-macro-def (name env
)
107 (loop for e in env thereis
(gethash name e
)))
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
118 (defmacro defpsmacro
(name args
&body body
)
119 `(progn (undefine-ps-special-form ',name
)
120 (setf (gethash ',name
*ps-macro-toplevel
*) ,(make-ps-macro-function args body
))
123 (defmacro define-ps-symbol-macro
(symbol expansion
)
125 `(progn (undefine-ps-special-form ',symbol
)
126 (setf (gethash ',symbol
*ps-symbol-macro-toplevel
*) (lambda (,x
) (declare (ignore ,x
)) ',expansion
))
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."
135 (eval `(defpsmacro ,name
(&rest args
)
136 (macroexpand `(,',name
,@args
))))))
138 (defmacro defmacro
/ps
(name args
&body body
)
139 "Define a Lisp macro and import it into the ParenScript macro environment."
140 `(progn (defmacro ,name
,args
,@body
)
141 (import-macros-from-lisp ',name
)))
143 (defmacro defmacro
+ps
(name args
&body body
)
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
149 `(progn (defmacro ,name
,args
,@body
)
150 (defpsmacro ,name
,args
,@body
)))
152 (defun ps-macroexpand (form)
153 (aif (or (and (symbolp form
) (lookup-macro-def form
*ps-symbol-macro-env
*))
154 (and (consp form
) (lookup-macro-def (car form
) *ps-macro-env
*)))
155 (values (ps-macroexpand (funcall it form
)) t
)
158 (defun maybe-rename-local-function (fun-name)
159 (aif (lookup-macro-def fun-name
*ps-local-function-names
*)
163 ;;;; compiler interface
164 (defun adjust-ps-compilation-level (form level
)
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
)))
171 ((eq :toplevel level
) :inside-toplevel-form
)))
174 (defun ps-compile-symbol (form)
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."
178 (let ((exp (ps-compile-expression form
)))
179 (when (eq (first exp
) 'js
:variable
)
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
)
185 (defmethod ps-compile (form)
186 (error "The object ~S cannot be compiled by ParenScript." form
))
188 (defmethod ps-compile ((form number
))
191 (defmethod ps-compile ((form string
))
194 (defmethod ps-compile ((form character
))
195 (ps-compile (string form
)))
197 (defmethod ps-compile ((symbol symbol
))
198 (when (eq *ps-compilation-level
* :toplevel
)
199 (multiple-value-bind (expansion expanded-p
)
200 (ps-macroexpand symbol
)
202 (return-from ps-compile
(ps-compile expansion
)))))
203 (cond ((keywordp symbol
) symbol
)
204 ((ps-special-form-p (list symbol
))
205 (if (ps-reserved-symbol-p symbol
)
206 (funcall (get-ps-special-form symbol
))
207 (error "Attempting to use Parenscript special form ~a as variable" symbol
)))
208 (t `(js:variable
,symbol
))))
212 (let ((precedence-table (make-hash-table :test
'eq
)))
213 (loop for level in
'((js:new js
:slot-value js
:aref
)
214 (postfix++ postfix--
)
215 (delete void typeof
++ -- unary
+ unary- ~
!)
219 (< > <= >= js
:instanceof js
:in
)
227 (= *= /= %
= += -
= <<= >>= >>>= \
&\
= ^
= \|
=)
230 do
(mapcar (lambda (symbol)
231 (setf (gethash symbol precedence-table
) i
))
233 (defun op-precedence (op)
234 (gethash op precedence-table
)))
236 (defun ps-convert-op-name (op)
245 (defun maybe-fix-nary-comparison-form (form)
246 (if (< 2 (length (cdr form
)))
248 (let* ((operator (car form
))
249 (tmp-var-forms (butlast (cddr form
)))
250 (tmp-vars (loop repeat
(length tmp-var-forms
)
251 collect
(ps-gensym "_cmp")))
252 (all-comparisons (append (list (cadr form
))
255 `(let ,(mapcar #'list tmp-vars tmp-var-forms
)
256 (and ,@(loop for x1 in all-comparisons
257 for x2 in
(cdr all-comparisons
)
258 collect
(list operator x1 x2
)))))
262 (defun compile-op-form (form)
263 `(js:operator
,(ps-convert-op-name (ps-compile-symbol (car form
)))
264 ,@(mapcar (lambda (form)
265 (ps-compile-expression (ps-macroexpand form
)))
268 (defun compile-funcall-form (form)
270 ,(ps-compile-expression (if (symbolp (car form
))
271 (maybe-rename-local-function (car form
))
272 (ps-macroexpand (car form
))))
273 ,@(mapcar #'ps-compile-expression
(cdr form
))))
275 (defvar compile-expression?
)
277 (defmethod ps-compile ((form cons
))
278 (multiple-value-bind (form expanded-p
)
279 (ps-macroexpand form
)
280 (let ((*ps-compilation-level
*
282 *ps-compilation-level
*
283 (adjust-ps-compilation-level form
*ps-compilation-level
*))))
286 ((ps-special-form-p form
)
287 (apply (get-ps-special-form (car form
)) (cdr form
)))
288 ((comparison-form-p form
)
289 (multiple-value-bind (form fixed?
)
290 (maybe-fix-nary-comparison-form form
)
293 (compile-op-form form
))))
295 (compile-op-form form
))
296 ((funcall-form-p form
)
297 (compile-funcall-form form
))
298 (t (error "Cannot compile ~S to a ParenScript form." form
))))))
300 (defun ps-compile-statement (form)
301 (let ((compile-expression? nil
))
304 (defun ps-compile-expression (form)
305 (let ((compile-expression? t
))
308 (defvar *ps-gensym-counter
* 0)
310 (defun ps-gensym (&optional
(prefix "_js"))
311 (let ((prefix (if (stringp prefix
) prefix
(symbol-to-js-string prefix nil
))))
312 (make-symbol (format nil
"~A~:[~;_~]~A" prefix
313 (digit-char-p (char prefix
(1- (length prefix
))))
314 (incf *ps-gensym-counter
*)))))
316 (defmacro with-ps-gensyms
(symbols &body body
)
317 "Evaluate BODY with SYMBOLS bound to unique ParenScript identifiers.
319 Each element of SYMBOLS is either a symbol or a list of (symbol
320 gensym-prefix-string)."
321 `(let* ,(mapcar (lambda (symbol)
322 (destructuring-bind (symbol &optional prefix
)
327 `(,symbol
(ps-gensym ,prefix
))
328 `(,symbol
(ps-gensym ,(symbol-to-js-string symbol
))))))
332 (defun %check-once-only-vars
(vars)
333 (let ((bad-var (find-if (lambda (x) (or (not (symbolp x
)) (keywordp x
))) vars
)))
335 (error "PS-ONLY-ONCE expected a non-keyword symbol but got ~s" bad-var
))))
337 (defmacro ps-once-only
((&rest vars
) &body body
)
338 (%check-once-only-vars vars
)
339 (let ((gensyms (mapcar (lambda (x) (ps-gensym (string x
))) vars
)))
340 `(let ,(mapcar (lambda (g v
) `(,g
(ps-gensym ,(string v
)))) gensyms vars
)
341 `(let* (,,@(mapcar (lambda (g v
) ``(,,g
,,v
)) gensyms vars
))
342 ,(let ,(mapcar (lambda (g v
) `(,v
,g
)) gensyms vars
)