1 ;;; Copyright 2005 Manuel Odendahl
2 ;;; Copyright 2005-2006 Edward Marco Baringer
3 ;;; Copyright 2006 Attila Lendvai
4 ;;; Copyright 2006 Luca Capello
5 ;;; Copyright 2007-2012, 2018 Vladimir Sedach
6 ;;; Copyright 2008 Travis Cross
7 ;;; Copyright 2009-2010 Red Daly
8 ;;; Copyright 2009-2010 Daniel Gackle
9 ;;; Copyright 2012, 2015 Boris Smilga
11 ;;; SPDX-License-Identifier: BSD-3-Clause
13 ;;; Redistribution and use in source and binary forms, with or
14 ;;; without modification, are permitted provided that the following
15 ;;; conditions are met:
17 ;;; 1. Redistributions of source code must retain the above copyright
18 ;;; notice, this list of conditions and the following disclaimer.
20 ;;; 2. Redistributions in binary form must reproduce the above
21 ;;; copyright notice, this list of conditions and the following
22 ;;; disclaimer in the documentation and/or other materials provided
23 ;;; with the distribution.
25 ;;; 3. Neither the name of the copyright holder nor the names of its
26 ;;; contributors may be used to endorse or promote products derived
27 ;;; from this software without specific prior written permission.
29 ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
30 ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
31 ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
32 ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
33 ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS
34 ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
35 ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
36 ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
37 ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
38 ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
39 ;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
40 ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
41 ;;; POSSIBILITY OF SUCH DAMAGE.
43 (in-package #:parenscript
)
44 (in-readtable :parenscript
)
46 (defvar *version
* 2.7 "Parenscript compiler version.")
48 (defparameter %compiling-reserved-forms-p% t
49 "Used to issue warnings when replacing PS special operators or macros.")
51 (defvar *defined-operators
* ()
52 "Special operators and macros defined by Parenscript. Replace at your own risk!")
54 (defun defined-operator-override-check (name &rest body
)
55 (when (and (not %compiling-reserved-forms-p%
) (member name
*defined-operators
*))
56 (warn 'simple-style-warning
57 :format-control
"Redefining Parenscript operator/macro ~A"
58 :format-arguments
(list name
)))
59 `(progn ,(when %compiling-reserved-forms-p%
`(pushnew ',name
*defined-operators
*))
62 (defvar *reserved-symbol-names
*
63 (list "break" "case" "catch" "continue" "default" "delete" "do" "else"
64 "finally" "for" "function" "if" "in" "instanceof" "new" "return"
65 "switch" "this" "throw" "try" "typeof" "var" "void" "while" "with"
66 "abstract" "boolean" "byte" "char" "class" "const" "debugger"
67 "double" "enum" "export" "extends" "final" "float" "goto"
68 "implements" "import" "int" "interface" "long" "native" "package"
69 "private" "protected" "public" "short" "static" "super"
70 "synchronized" "throws" "transient" "volatile" "{}" "true" "false"
73 (defvar *lambda-wrappable-statements
*
74 '(throw switch for for-in while try block
)
75 "Statement special forms that can be wrapped in a lambda to make
76 them into expressions. Control transfer forms like BREAK, RETURN,
77 and CONTINUE need special treatment, and are not included.")
79 (defun reserved-symbol-p (symbol)
80 (find (string-downcase (string symbol
)) *reserved-symbol-names
* :test
#'string
=))
84 (defvar *special-expression-operators
* (make-hash-table :test
'eq
))
85 (defvar *special-statement-operators
* (make-hash-table :test
'eq
))
87 ;; need to split special op definition into two parts - statement and expression
88 (defmacro %define-special-operator
(type name lambda-list
&body body
)
89 (defined-operator-override-check name
90 `(setf (gethash ',name
,type
)
92 (destructuring-bind ,lambda-list whole
95 (defmacro define-expression-operator
(name lambda-list
&body body
)
96 `(%define-special-operator
*special-expression-operators
*
97 ,name
,lambda-list
,@body
))
99 (defmacro define-statement-operator
(name lambda-list
&body body
)
100 `(%define-special-operator
*special-statement-operators
*
101 ,name
,lambda-list
,@body
))
103 (defun special-form?
(form)
106 (or (gethash (car form
) *special-expression-operators
*)
107 (gethash (car form
) *special-statement-operators
*))))
109 ;;; naming, scoping, and lexical environment
111 (defvar *ps-gensym-counter
* 0)
113 (defvar *vars-needing-to-be-declared
* ()
114 "This special variable is expected to be bound to a fresh list by
115 special forms that introduce a new JavaScript lexical block (currently
116 function definitions and lambdas). Enclosed special forms are expected
117 to push variable declarations onto the list when the variables
118 declaration cannot be made by the enclosed form (for example, a x,y,z
119 expression progn). It is then the responsibility of the enclosing
120 special form to introduce the variable declarations in its lexical
123 (defvar *used-up-names
*)
124 (setf (documentation '*used-up-names
* 'variable
)
125 "Names that have been already used for lexical bindings in the current function scope.")
128 "Bind to T when compiling CASE branches.")
130 (defvar in-loop-scope? nil
131 "Used for seeing when we're in loops, so that we can introduce
132 proper scoping for lambdas closing over loop-bound
133 variables (otherwise they all share the same binding).")
134 (defvar *loop-return-var
* nil
135 "Variable which is used to return values from inside loop bodies.")
136 (defvar *loop-return-set-var
* nil
137 "Variable which is set by RETURN-FROM when it returns a value from inside
138 a loop. The value is the name of a PS variable which dynamically
139 indicates if the return statement indeed has been invoked.")
141 (defvar *loop-scope-lexicals
*)
142 (setf (documentation '*loop-scope-lexicals
* 'variable
)
143 "Lexical variables introduced by a loop.")
144 (defvar *loop-scope-lexicals-captured
*)
145 (setf (documentation '*loop-scope-lexicals-captured
* 'variable
)
146 "Lexical variables introduced by a loop that are also captured by lambdas inside a loop.")
148 (defvar in-function-scope? nil
149 "Lets the compiler know when lambda wrapping is necessary.")
151 (defvar *local-function-names
* ()
152 "Functions named by flet and label.")
154 (defvar *enclosing-lexicals
* ()
155 "All enclosing lexical variables (includes function names).")
156 (defvar *enclosing-function-arguments
* ()
157 "Lexical variables bound in all lexically enclosing function argument lists.")
159 (defvar *function-block-names
* ()
160 "All block names that this function is responsible for catching.")
161 (defvar *dynamic-return-tags
* ()
162 "Tags that need to be thrown to to reach.")
163 (defvar *current-block-tag
* nil
164 "Name of the lexically enclosing block, if any.")
166 (defvar *special-variables
* ()
167 "Special variables declared during any Parenscript run. Re-bind this if you want to clear the list.")
169 (defun special-variable?
(sym)
170 (member sym
*special-variables
*))
174 (defvar *macro-toplevel-lambda-list
* (make-hash-table)
175 "Table of lambda lists for toplevel macros.")
177 (defvar *function-lambda-list
* (make-hash-table)
178 "Table of lambda lists for defined functions.")
181 (defun make-macro-dictionary ()
182 (make-hash-table :test
'eq
))
184 (defvar *macro-toplevel
* (make-macro-dictionary)
185 "Toplevel macro environment dictionary.")
187 (defvar *macro-env
* (list *macro-toplevel
*)
188 "Current macro environment.")
190 (defvar *symbol-macro-toplevel
* (make-macro-dictionary))
192 (defvar *symbol-macro-env
* (list *symbol-macro-toplevel
*))
194 (defvar *setf-expanders
* (make-macro-dictionary)
195 "Setf expander dictionary. Key is the symbol of the access
196 function of the place, value is an expansion function that takes the
197 arguments of the access functions as a first value and the form to be
198 stored as the second value.")
200 (defun lookup-macro-def (name env
)
201 (loop for e in env thereis
(gethash name e
)))
203 (defun make-ps-macro-function (args body
)
204 "Given the arguments and body to a parenscript macro, returns a
205 function that may be called on the entire parenscript form and outputs
206 some parenscript code. Returns a second value that is the effective
207 lambda list from a Parenscript perspective."
208 (let* ((whole-var (when (eql '&whole
(first args
)) (second args
)))
209 (effective-lambda-list (if whole-var
(cddr args
) args
))
210 (whole-arg (or whole-var
(gensym "ps-macro-form-arg-"))))
212 `(lambda (,whole-arg
)
213 (destructuring-bind ,effective-lambda-list
216 effective-lambda-list
)))
218 (defmacro defpsmacro
(name args
&body body
)
219 (defined-operator-override-check name
220 (multiple-value-bind (macro-fn-form effective-lambda-list
)
221 (make-ps-macro-function args body
)
222 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
223 (setf (gethash ',name
*macro-toplevel
*) ,macro-fn-form
)
224 (setf (gethash ',name
*macro-toplevel-lambda-list
*) ',effective-lambda-list
)
227 (defmacro define-ps-symbol-macro
(symbol expansion
)
228 (defined-operator-override-check symbol
229 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
230 (setf (gethash ',symbol
*symbol-macro-toplevel
*)
232 (declare (ignore form
))
235 (defun import-macros-from-lisp (&rest names
)
236 "Import the named Lisp macros into the Parenscript macro
237 environment. When the imported macro is macroexpanded by Parenscript,
238 it is first fully macroexpanded in the Lisp macro environment, and
239 then that expansion is further expanded by Parenscript."
241 (eval `(defpsmacro ,name
(&rest args
)
242 (macroexpand `(,',name
,@args
))))))
244 (defmacro defmacro
+ps
(name args
&body body
)
245 "Define a Lisp macro and a Parenscript macro with the same macro
246 function (ie - the same result from macroexpand-1), for cases when the
247 two have different full macroexpansions (for example if the CL macro
248 contains implementation-specific code when macroexpanded fully in the
250 `(progn (defmacro ,name
,args
,@body
)
251 (defpsmacro ,name
,args
,@body
)))
253 (defun symbol-macro?
(form)
254 "If FORM is a symbol macro, return its macro function. Otherwise,
257 (or (and (member form
*enclosing-lexicals
*)
258 (lookup-macro-def form
*symbol-macro-env
*))
259 (gethash form
*symbol-macro-toplevel
*))))
261 (defun ps-macroexpand-1 (form)
262 (aif (or (symbol-macro? form
)
263 (and (consp form
) (lookup-macro-def (car form
) *macro-env
*)))
264 (values (ps-macroexpand (funcall it form
)) t
)
267 (defun ps-macroexpand (form)
268 (multiple-value-bind (form1 expanded?
)
269 (ps-macroexpand-1 form
)
271 (values (ps-macroexpand form1
) t
)
274 ;;;; compiler interface
276 (defparameter *compilation-level
* :toplevel
277 "This value takes on the following values:
278 :toplevel indicates that we are traversing toplevel forms.
279 :inside-toplevel-form indicates that we are inside a call to ps-compile-*
280 nil indicates we are no longer toplevel-related.")
282 (defun adjust-compilation-level (form level
)
283 "Given the current *compilation-level*, LEVEL, and the fully macroexpanded
284 form, FORM, returns the new value for *compilation-level*."
285 (cond ((or (and (consp form
)
286 (member (car form
) '(progn locally macrolet symbol-macrolet
)))
287 (and (symbolp form
) (eq :toplevel level
)))
289 ((eq :toplevel level
) :inside-toplevel-form
)))
291 (defvar compile-expression?
)
293 (define-condition compile-expression-error
(error)
294 ((form :initarg
:form
:reader error-form
))
296 (lambda (condition stream
)
299 "The Parenscript form ~A cannot be compiled into an expression."
300 (error-form condition
)))))
302 (defun compile-special-form (form)
303 (let* ((op (car form
))
304 (statement-impl (gethash op
*special-statement-operators
*))
305 (expression-impl (gethash op
*special-expression-operators
*)))
306 (cond ((not compile-expression?
)
307 (apply (or statement-impl expression-impl
) (cdr form
)))
309 (apply expression-impl
(cdr form
)))
310 ((member op
*lambda-wrappable-statements
*)
311 (compile-expression (with-lambda-scope form
)))
313 (error 'compile-expression-error
:form form
)))))
315 (defun ps-compile (form)
317 ((try-expanding (form &body body
)
318 `(multiple-value-bind (expansion expanded?
)
319 (ps-macroexpand ,form
)
321 (ps-compile expansion
)
324 ((or null number string character
)
327 (ps-compile `(quote ,(coerce form
'list
))))
329 (try-expanding form form
))
332 (let ((*compilation-level
*
333 (adjust-compilation-level form
*compilation-level
*)))
334 (if (special-form? form
)
335 (compile-special-form form
)
337 ,(if (symbolp (car form
))
338 (maybe-rename-local-function (car form
))
339 (compile-expression (car form
)))
340 ,@(mapcar #'compile-expression
(cdr form
))))))))))
342 (defun compile-statement (form)
343 (let ((compile-expression? nil
))
346 (defun compile-expression (form)
347 (let ((compile-expression? t
))
350 (defun ps-gensym (&optional
(x '_js
))
353 (format nil
"~A~A" '_js x
)
354 (let ((prefix (string x
)))
355 (format nil
"~A~:[~;_~]~A"
357 (digit-char-p (char prefix
(1- (length prefix
))))
358 (incf *ps-gensym-counter
*))))))
360 (defmacro with-ps-gensyms
(symbols &body body
)
361 "Helper macro for writing Parenscript macros. Each element of
362 SYMBOLS is either a symbol or a list of (symbol
363 gensym-prefix-string)."
364 `(let* ,(mapcar (lambda (symbol)
365 (destructuring-bind (symbol &optional prefix
)
370 `(,symbol
(ps-gensym ,(string prefix
)))
371 `(,symbol
(ps-gensym ,(string symbol
))))))
375 (defmacro ps-once-only
((&rest vars
) &body body
)
376 "Helper macro for writing Parenscript macros. Useful for preventing unwanted multiple evaluation."
377 (warn-deprecated 'ps-once-only
'maybe-once-only
)
378 (let ((gensyms (mapcar #'ps-gensym vars
)))
379 `(let* ,(mapcar (lambda (g v
) `(,g
(ps-gensym ',v
)))
381 `(let* (,,@(mapcar (lambda (g v
) `(list ,g
,v
))
383 ,(let* ,(mapcar (lambda (g v
) (list v g
))
387 (defmacro maybe-once-only
((&rest vars
) &body body
)
388 "Helper macro for writing Parenscript macros. Like PS-ONCE-ONLY,
389 except that if the given VARS are variables or constants, no intermediate variables are created."
390 (let ((vars-bound (gensym)))
393 ,@(loop for var in vars collect
395 (let ((form (ps-macroexpand ,var
)))
398 (let ((var¹
(ps-gensym ',var
)))
399 (push (list var¹ form
) ,vars-bound
)
401 `(let* ,(nreverse ,vars-bound
)