1 (in-package #:parenscript
)
2 (in-readtable :parenscript
)
4 (defvar *version
* 2.3 "Parenscript compiler version.")
6 (defparameter %compiling-reserved-forms-p% t
7 "Used to issue warnings when replacing PS special operators or macros.")
9 (defvar *defined-operators
* ()
10 "Special operators and macros defined by Parenscript. Replace at your own risk!")
12 (defun defined-operator-override-check (name &rest body
)
13 (when (and (not %compiling-reserved-forms-p%
) (member name
*defined-operators
*))
14 (warn 'simple-style-warning
15 :format-control
"Redefining Parenscript operator/macro ~A"
16 :format-arguments
(list name
)))
17 `(progn ,(when %compiling-reserved-forms-p%
`(pushnew ',name
*defined-operators
*))
20 (defvar *reserved-symbol-names
*
21 (list "break" "case" "catch" "continue" "default" "delete" "do" "else"
22 "finally" "for" "function" "if" "in" "instanceof" "new" "return"
23 "switch" "this" "throw" "try" "typeof" "var" "void" "while" "with"
24 "abstract" "boolean" "byte" "char" "class" "const" "debugger" "double"
25 "enum" "export" "extends" "final" "float" "goto" "implements" "import"
26 "int" "interface" "long" "native" "package" "private" "protected"
27 "public" "short" "static" "super" "synchronized" "throws" "transient"
28 "volatile" "{}" "true" "false" "null" "undefined"))
30 (defvar *lambda-wrappable-statements
* ;; break, return, continue not included
31 '(throw switch for for-in while try block
))
33 (defun reserved-symbol?
(symbol)
34 (find (string-downcase (string symbol
)) *reserved-symbol-names
* :test
#'string
=))
38 (defvar *special-expression-operators
* (make-hash-table :test
'eq
))
39 (defvar *special-statement-operators
* (make-hash-table :test
'eq
))
41 ;; need to split special op definition into two parts - statement and expression
42 (defmacro %define-special-operator
(type name lambda-list
&body body
)
43 (defined-operator-override-check name
44 `(setf (gethash ',name
,type
)
46 (destructuring-bind ,lambda-list whole
49 (defmacro define-expression-operator
(name lambda-list
&body body
)
50 `(%define-special-operator
*special-expression-operators
*
51 ,name
,lambda-list
,@body
))
53 (defmacro define-statement-operator
(name lambda-list
&body body
)
54 `(%define-special-operator
*special-statement-operators
*
55 ,name
,lambda-list
,@body
))
57 (defun special-form?
(form)
60 (or (gethash (car form
) *special-expression-operators
*)
61 (gethash (car form
) *special-statement-operators
*))))
63 ;;; scoping and lexical environment
65 (defvar *vars-needing-to-be-declared
* ()
66 "This special variable is expected to be bound to a fresh list by
67 special forms that introduce a new JavaScript lexical block (currently
68 function definitions and lambdas). Enclosed special forms are expected
69 to push variable declarations onto the list when the variables
70 declaration cannot be made by the enclosed form (for example, a x,y,z
71 expression progn). It is then the responsibility of the enclosing
72 special form to introduce the variable declarations in its lexical
75 (defvar *used-up-names
*)
76 (setf (documentation '*used-up-names
* 'variable
)
77 "Names that have been already used for lexical bindings in the current function scope.")
80 "Bind to T when compiling CASE branches.")
82 (defvar in-loop-scope? nil
83 "Used for seeing when we're in loops, so that we can introduce
84 proper scoping for lambdas closing over loop-bound
85 variables (otherwise they all share the same binding).")
86 (defvar *loop-return-var
* nil
87 "Variable which is used to return values from inside loop bodies.")
88 (defvar loop-returns? nil
89 "Set to T by RETURN-FROM when it returns a value from inside a loop.")
91 (defvar *loop-scope-lexicals
*)
92 (setf (documentation '*loop-scope-lexicals
* 'variable
)
93 "Lexical variables introduced by a loop.")
94 (defvar *loop-scope-lexicals-captured
*)
95 (setf (documentation '*loop-scope-lexicals-captured
* 'variable
)
96 "Lexical variables introduced by a loop that are also captured by lambdas inside a loop.")
98 (defvar in-function-scope? nil
99 "Lets the compiler know when lambda wrapping is necessary.")
101 (defvar *local-function-names
* ()
102 "Functions named by flet and label.")
104 (defvar *enclosing-lexicals
* ()
105 "All enclosing lexical variables (includes function names).")
106 (defvar *enclosing-function-arguments
* ()
107 "Lexical variables bound in all lexically enclosing function argument lists.")
109 (defvar *function-block-names
* ()
110 "All block names that this function is responsible for catching.")
111 (defvar *dynamic-return-tags
* ()
112 "Tags that need to be thrown to to reach.")
113 (defvar *current-block-tag
* nil
114 "Name of the lexically enclosing block, if any.")
116 (defvar *special-variables
* ()
117 "Special variables declared during any Parenscript run. Re-bind this if you want to clear the list.")
119 (defun special-variable?
(sym)
120 (member sym
*special-variables
*))
124 (defvar *macro-toplevel-lambda-list
* (make-hash-table)
125 "Table of lambda lists for toplevel macros.")
127 (defvar *function-lambda-list
* (make-hash-table)
128 "Table of lambda lists for defined functions.")
131 (defun make-macro-dictionary ()
132 (make-hash-table :test
'eq
))
134 (defvar *macro-toplevel
* (make-macro-dictionary)
135 "Toplevel macro environment dictionary.")
137 (defvar *macro-env
* (list *macro-toplevel
*)
138 "Current macro environment.")
140 (defvar *symbol-macro-toplevel
* (make-macro-dictionary))
142 (defvar *symbol-macro-env
* (list *symbol-macro-toplevel
*))
144 (defvar *setf-expanders
* (make-macro-dictionary)
145 "Setf expander dictionary. Key is the symbol of the access
146 function of the place, value is an expansion function that takes the
147 arguments of the access functions as a first value and the form to be
148 stored as the second value.")
150 (defun lookup-macro-def (name env
)
151 (loop for e in env thereis
(gethash name e
)))
153 (defun make-ps-macro-function (args body
)
154 "Given the arguments and body to a parenscript macro, returns a
155 function that may be called on the entire parenscript form and outputs
156 some parenscript code. Returns a second value that is the effective
157 lambda list from a Parenscript perspective."
158 (let* ((whole-var (when (eql '&whole
(first args
)) (second args
)))
159 (effective-lambda-list (if whole-var
(cddr args
) args
))
160 (whole-arg (or whole-var
(gensym "ps-macro-form-arg-"))))
162 `(lambda (,whole-arg
)
163 (destructuring-bind ,effective-lambda-list
166 effective-lambda-list
)))
168 (defmacro defpsmacro
(name args
&body body
)
169 (defined-operator-override-check name
170 (multiple-value-bind (macro-fn-form effective-lambda-list
)
171 (make-ps-macro-function args body
)
173 (setf (gethash ',name
*macro-toplevel
*) ,macro-fn-form
)
174 (setf (gethash ',name
*macro-toplevel-lambda-list
*) ',effective-lambda-list
)
177 (defmacro define-ps-symbol-macro
(symbol expansion
)
178 (defined-operator-override-check symbol
179 `(setf (gethash ',symbol
*symbol-macro-toplevel
*) (lambda (form) (declare (ignore form
)) ',expansion
))))
181 (defun import-macros-from-lisp (&rest names
)
182 "Import the named Lisp macros into the Parenscript macro
183 environment. When the imported macro is macroexpanded by Parenscript,
184 it is first fully macroexpanded in the Lisp macro environment, and
185 then that expansion is further expanded by Parenscript."
187 (eval `(defpsmacro ,name
(&rest args
)
188 (macroexpand `(,',name
,@args
))))))
190 (defmacro defmacro
+ps
(name args
&body body
)
191 "Define a Lisp macro and a Parenscript macro with the same macro
192 function (ie - the same result from macroexpand-1), for cases when the
193 two have different full macroexpansions (for example if the CL macro
194 contains implementation-specific code when macroexpanded fully in the
196 `(progn (defmacro ,name
,args
,@body
)
197 (defpsmacro ,name
,args
,@body
)))
199 (defun ps-macroexpand-1 (form)
200 (aif (or (and (symbolp form
)
201 (or (and (member form
*enclosing-lexicals
*)
202 (lookup-macro-def form
*symbol-macro-env
*))
203 (gethash form
*symbol-macro-toplevel
*))) ;; hack
204 (and (consp form
) (lookup-macro-def (car form
) *macro-env
*)))
205 (values (ps-macroexpand (funcall it form
)) t
)
208 (defun ps-macroexpand (form)
209 (multiple-value-bind (form1 expanded?
) (ps-macroexpand-1 form
)
211 (values (ps-macroexpand form1
) t
)
214 ;;;; compiler interface
216 (defparameter *compilation-level
* :toplevel
217 "This value takes on the following values:
218 :toplevel indicates that we are traversing toplevel forms.
219 :inside-toplevel-form indicates that we are inside a call to ps-compile-*
220 nil indicates we are no longer toplevel-related.")
222 (defun adjust-compilation-level (form level
)
223 "Given the current *compilation-level*, LEVEL, and the fully macroexpanded
224 form, FORM, returns the new value for *compilation-level*."
225 (cond ((or (and (consp form
)
226 (member (car form
) '(progn locally macrolet symbol-macrolet
)))
227 (and (symbolp form
) (eq :toplevel level
)))
229 ((eq :toplevel level
) :inside-toplevel-form
)))
231 (defvar compile-expression?
)
233 (define-condition compile-expression-error
(error)
234 ((form :initarg
:form
:reader error-form
))
235 (:report
(lambda (condition stream
)
236 (format stream
"The Parenscript form ~A cannot be compiled into an expression." (error-form condition
)))))
238 (defun compile-special-form (form)
239 (let* ((op (car form
))
240 (statement-impl (gethash op
*special-statement-operators
*))
241 (expression-impl (gethash op
*special-expression-operators
*)))
242 (cond ((not compile-expression?
)
243 (apply (or statement-impl expression-impl
) (cdr form
)))
245 (apply expression-impl
(cdr form
)))
246 ((member op
*lambda-wrappable-statements
*)
247 (compile-expression `((lambda () ,form
))))
248 (t (error 'compile-expression-error
:form form
)))))
250 (defun ps-compile (form)
252 ((or null number string character
) form
)
253 (vector (ps-compile `(quote ,(coerce form
'list
))))
255 (multiple-value-bind (expansion expanded?
) (ps-macroexpand form
)
257 (ps-compile expansion
)
260 (let ((*compilation-level
*
261 (adjust-compilation-level form
*compilation-level
*)))
262 (if (special-form? form
)
263 (compile-special-form form
)
265 ,(if (symbolp (car form
))
266 (maybe-rename-local-function (car form
))
267 (compile-expression (car form
)))
268 ,@(mapcar #'compile-expression
(cdr form
)))))))))))
270 (defun compile-statement (form)
271 (let ((compile-expression? nil
))
274 (defun compile-expression (form)
275 (let ((compile-expression? t
))
278 (defvar *ps-gensym-counter
* 0)
280 (defun ps-gensym (&optional
(prefix-or-counter "_JS"))
281 (assert (or (stringp prefix-or-counter
) (integerp prefix-or-counter
)))
282 (let ((prefix (if (stringp prefix-or-counter
) prefix-or-counter
"_JS"))
283 (counter (if (integerp prefix-or-counter
) prefix-or-counter
(incf *ps-gensym-counter
*))))
284 (make-symbol (format nil
"~A~:[~;_~]~A" prefix
285 (digit-char-p (char prefix
(1- (length prefix
))))
288 (defmacro with-ps-gensyms
(symbols &body body
)
289 "Each element of SYMBOLS is either a symbol or a list of (symbol
290 gensym-prefix-string)."
291 `(let* ,(mapcar (lambda (symbol)
292 (destructuring-bind (symbol &optional prefix
)
297 `(,symbol
(ps-gensym ,(string prefix
)))
298 `(,symbol
(ps-gensym ,(string symbol
))))))
302 (defmacro ps-once-only
((&rest vars
) &body body
)
303 (let ((gensyms (mapcar (lambda (x) (ps-gensym (string x
))) vars
)))
304 `(let ,(mapcar (lambda (g v
) `(,g
(ps-gensym ,(string v
)))) gensyms vars
)
305 `(let* (,,@(mapcar (lambda (g v
) ``(,,g
,,v
)) gensyms vars
))
306 ,(let ,(mapcar (lambda (g v
) `(,v
,g
)) gensyms vars
)