1 (in-package "PARENSCRIPT")
3 ;;; reserved symbols/literals
5 (defvar *ps-reserved-symbol-names
* ()) ;; symbol names reserved for PS/JS literals
7 (defun add-ps-literal (name)
8 (push (symbol-name name
) *ps-reserved-symbol-names
*))
10 (defun ps-literal-p (symbol)
11 (find (symbol-name symbol
) *ps-reserved-symbol-names
* :test
#'equalp
))
15 (defvar *ps-special-forms
* (make-hash-table :test
'eq
))
17 (defun get-ps-special-form (name)
18 (gethash name
*ps-special-forms
*))
20 (defmacro define-ps-special-form
(name lambda-list
&rest body
)
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."
25 (let ((args (gensym "ps-arglist-"))
26 (expecting-used-p (member 'expecting
(flatten body
))))
27 `(setf (gethash ',name
*ps-special-forms
*)
29 (destructuring-bind ,(cons 'expecting lambda-list
)
31 ,(unless expecting-used-p
'(declare (ignore expecting
)))
34 (defun undefine-ps-special-form (name)
35 (remhash name
*ps-special-forms
*))
37 (defun ps-special-form-p (form)
40 (gethash (car form
) *ps-special-forms
*)))
44 (defvar *enclosing-lexical-block-declarations
* ()
45 "This special variable is expected to be bound to a fresh list by
46 special forms that introduce a new JavaScript lexical block (currently
47 function definitions and lambdas). Enclosed special forms are expected
48 to push variable declarations onto the list when the variables
49 declaration cannot be made by the enclosed form \(for example, a
50 \(x,y,z\) expression progn\). It is then the responsibility of the
51 enclosing special form to introduce the variable bindings in its
54 (defvar *ps-special-variables
* ())
58 (defun op-form-p (form)
60 (not (ps-special-form-p form
))
61 (not (null (op-precedence (first form
))))))
63 (defun funcall-form-p (form)
65 (not (op-form-p form
))
66 (not (ps-special-form-p form
))))
69 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
70 (defun make-macro-env-dictionary ()
71 (make-hash-table :test
'eq
))
72 (defvar *ps-macro-toplevel
* (make-macro-env-dictionary)
73 "Toplevel macro environment dictionary. Key is the symbol name of
74 the macro, value is (symbol-macro-p . expansion-function).")
75 (defvar *ps-macro-env
* (list *ps-macro-toplevel
*)
76 "Current macro environment.")
78 (defvar *ps-setf-expanders
* (make-macro-env-dictionary)
79 "Setf expander dictionary. Key is the symbol of the access
80 function of the place, value is an expansion function that takes the
81 arguments of the access functions as a first value and the form to be
82 stored as the second value.")
84 (defun get-macro-spec (name env-dict
)
85 "Retrieves the macro spec of the given name with the given environment dictionary.
86 SPEC is of the form (symbol-macro-p . expansion-function)."
87 (gethash name env-dict
))
88 (defsetf get-macro-spec
(name env-dict
)
90 `(setf (gethash ,name
,env-dict
) ,spec
)))
92 (defun lookup-macro-spec (name &optional
(environment *ps-macro-env
*))
93 "Looks up the macro spec associated with NAME in the given environment. A
94 macro spec is of the form (symbol-macro-p . function). Returns two values:
95 the SPEC and the parent macro environment.
97 NAME must be a symbol."
99 (do ((env environment
(cdr env
)))
101 (let ((val (get-macro-spec name
(car env
))))
103 (return-from lookup-macro-spec
104 (values val
(or (cdr env
)
105 (list *ps-macro-toplevel
*)))))))))
107 (defun ps-symbol-macro-p (name &optional
(environment *ps-macro-env
*))
108 "True if there is a Parenscript symbol macro named by the symbol NAME."
109 (and (symbolp name
) (car (lookup-macro-spec name environment
))))
111 (defun ps-macro-p (name &optional
(environment *ps-macro-env
*))
112 "True if there is a Parenscript macro named by the symbol NAME."
114 (let ((macro-spec (lookup-macro-spec name environment
)))
115 (and macro-spec
(not (car macro-spec
))))))
117 (defun lookup-macro-expansion-function (name &optional
(environment *ps-macro-env
*))
118 "Lookup NAME in the given macro expansion environment (which
119 defaults to the current macro environment). Returns the expansion
120 function and the parent macro environment of the macro."
121 (multiple-value-bind (macro-spec parent-env
)
122 (lookup-macro-spec name environment
)
123 (values (cdr macro-spec
) parent-env
)))
125 (defun make-ps-macro-function (args body
)
126 (let* ((whole-var (when (eql '&whole
(first args
)) (second args
)))
127 (effective-lambda-list (if whole-var
(cddr args
) args
))
128 (whole-arg (or whole-var
(gensym "ps-macro-form-arg-"))))
129 `(lambda (,whole-arg
)
130 (destructuring-bind ,effective-lambda-list
134 (defmacro defpsmacro
(name args
&body body
)
135 `(progn (undefine-ps-special-form ',name
)
136 (setf (get-macro-spec ',name
*ps-macro-toplevel
*)
137 (cons nil
,(make-ps-macro-function args body
)))
140 (defmacro define-ps-symbol-macro
(symbol expansion
)
142 `(progn (undefine-ps-special-form ',symbol
)
143 (setf (get-macro-spec ',symbol
*ps-macro-toplevel
*) (cons t
(lambda (,x
) (declare (ignore ,x
)) ',expansion
)))
146 (defun import-macros-from-lisp (&rest names
)
147 "Import the named Lisp macros into the ParenScript macro
148 environment. When the imported macro is macroexpanded by ParenScript,
149 it is first fully macroexpanded in the Lisp macro environment, and
150 then that expansion is further expanded by ParenScript."
152 (eval `(defpsmacro ,name
(&rest args
)
153 (macroexpand `(,',name
,@args
))))))
155 (defmacro defmacro
/ps
(name args
&body body
)
156 "Define a Lisp macro and import it into the ParenScript macro environment."
157 `(progn (defmacro ,name
,args
,@body
)
158 (import-macros-from-lisp ',name
)))
160 (defmacro defmacro
+ps
(name args
&body body
)
161 "Define a Lisp macro and a ParenScript macro with the same macro
162 function (ie - the same result from macroexpand-1), for cases when the
163 two have different full macroexpansions (for example if the CL macro
164 contains implementation-specific code when macroexpanded fully in the
166 `(progn (defmacro ,name
,args
,@body
)
167 (defpsmacro ,name
,args
,@body
)))
169 (defun ps-macroexpand (form)
170 "Recursively macroexpands ParenScript macros and symbol-macros in
171 the given ParenScript form. Returns two values: the expanded form, and
172 whether any expansion was performed on the form or not."
173 (let ((macro-function (cond ((ps-symbol-macro-p form
) form
)
174 ((and (consp form
) (ps-macro-p (car form
))) (car form
)))))
176 (values (ps-macroexpand (funcall (lookup-macro-expansion-function macro-function
) form
)) t
)
179 ;;;; compiler interface
180 (defgeneric compile-parenscript-form
(form &key expecting
)
181 (:documentation
"Compiles a ParenScript form to the intermediate
182 ParenScript representation. :expecting determines whether the form is
183 compiled to an :expression (the default), a :statement, or a
186 (defmethod compile-parenscript-form :around
(form &key expecting
)
187 (assert (if expecting
(member expecting
'(:expression
:statement
:symbol
)) t
))
188 (if (eql expecting
:symbol
)
189 (compile-to-symbol form
)
190 (multiple-value-bind (expanded-form expanded-p
)
191 (ps-macroexpand form
)
193 (compile-parenscript-form expanded-form
:expecting expecting
)
194 (call-next-method)))))
196 (defun compile-to-symbol (form)
197 "Compiles the given Parenscript form and guarantees that the
198 resultant symbol has an associated script-package. Raises an error if
199 the form cannot be compiled to a symbol."
200 (let ((exp (compile-parenscript-form form
)))
201 (when (eql (first exp
) 'js-variable
)
202 (setf exp
(second exp
)))
203 (assert (symbolp exp
) ()
204 "~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
)
207 (defmethod compile-parenscript-form (form &key expecting
)
208 (declare (ignore expecting
))
209 (error "The object ~S cannot be compiled by ParenScript." form
))
211 (defmethod compile-parenscript-form ((form number
) &key expecting
)
212 (declare (ignore expecting
))
215 (defmethod compile-parenscript-form ((form string
) &key expecting
)
216 (declare (ignore expecting
))
219 (defmethod compile-parenscript-form ((form character
) &key expecting
)
220 (declare (ignore expecting
))
221 (compile-parenscript-form (string form
)))
223 (defmethod compile-parenscript-form ((symbol symbol
) &key expecting
)
224 (declare (ignore expecting
))
225 (cond ((keywordp symbol
) symbol
)
226 ((ps-special-form-p (list symbol
))
227 (if (ps-literal-p symbol
)
228 (funcall (get-ps-special-form symbol
) :symbol
)
229 (error "Attempting to use Parenscript special form ~a as variable" symbol
)))
230 (t (list 'js-variable symbol
))))
232 (defun compile-function-argument-forms (args)
233 (let ((remaining-args args
))
234 (loop while remaining-args collecting
235 (if (keywordp (first remaining-args
))
236 (prog2 (when (oddp (length remaining-args
))
237 (error "Odd number of keyword arguments: ~A." args
))
238 (compile-parenscript-form (cons 'create remaining-args
) :expecting
:expression
)
239 (setf remaining-args nil
))
240 (prog1 (compile-parenscript-form (first remaining-args
) :expecting
:expression
)
241 (setf remaining-args
(cdr remaining-args
)))))))
243 (defun ps-convert-op-name (op)
244 (case (ensure-ps-symbol op
)
252 (defmethod compile-parenscript-form ((form cons
) &key
(expecting :statement
))
253 (let* ((name (car form
))
255 (cond ((ps-special-form-p form
) (apply (get-ps-special-form name
) (cons expecting args
)))
258 (ps-convert-op-name (compile-parenscript-form (first form
) :expecting
:symbol
))
259 (mapcar (lambda (form) (compile-parenscript-form form
:expecting
:expression
)) (rest form
))))
260 ((funcall-form-p form
)
262 (compile-parenscript-form name
:expecting
:expression
)
263 (compile-function-argument-forms args
)))
264 (t (error "Cannot compile ~S to a ParenScript form." form
)))))
266 (defvar *ps-gensym-counter
* 0)
268 (defun ps-gensym (&optional
(prefix "_js"))
269 (make-symbol (format nil
"~A~A" prefix
(incf *ps-gensym-counter
*))))
271 (defmacro with-ps-gensyms
(symbols &body body
)
272 "Evaluate BODY with SYMBOLS bound to unique ParenScript identifiers.
274 Each element of SYMBOLS is either a symbol or a list of (symbol
275 gensym-prefix-string)."
276 `(let* ,(mapcar (lambda (symbol)
277 (destructuring-bind (symbol &optional prefix
)
282 `(,symbol
(ps-gensym ,prefix
))
283 `(,symbol
(ps-gensym ,(symbol-to-js-string symbol
))))))
287 (defun %check-once-only-vars
(vars)
288 (let ((bad-var (find-if (lambda (x) (or (not (symbolp x
)) (keywordp x
))) vars
)))
290 (error "PS-ONLY-ONCE expected a non-keyword symbol but got ~s" bad-var
))))
292 (defmacro ps-once-only
((&rest vars
) &body body
)
293 (%check-once-only-vars vars
)
294 (let ((gensyms (mapcar (lambda (x) (ps-gensym (string x
))) vars
)))
295 `(let ,(mapcar (lambda (g v
) `(,g
(ps-gensym ,(string v
)))) gensyms vars
)
296 `(let* (,,@(mapcar (lambda (g v
) ``(,,g
,,v
)) gensyms vars
))
297 ,(let ,(mapcar (lambda (g v
) `(,v
,g
)) gensyms vars
)