1 (in-package :parenscript
)
3 ;;;; The macrology of the Parenscript language. Special forms and macros.
5 ;;; parenscript gensyms
6 (defvar *gen-script-name-counter
* 0)
8 (defun gen-script-name-string (&key
(prefix "_js_"))
9 "Generates a unique valid javascript identifier ()"
11 prefix
(princ-to-string (incf *gen-script-name-counter
*))))
13 (defun gen-script-name (&key
(prefix "_ps_"))
14 "Generate a new javascript identifier."
15 (intern (gen-script-name-string :prefix prefix
)
18 (defmacro with-unique-js-names
(symbols &body body
)
19 "Evaluate BODY with the variables on SYMBOLS bound to new javascript identifiers.
21 Each element of SYMBOLS is either a symbol or a list of (symbol
23 `(let* ,(mapcar (lambda (symbol)
24 (destructuring-bind (symbol &optional prefix
)
29 `(,symbol
(gen-script-name :prefix
,prefix
))
30 `(,symbol
(gen-script-name)))))
34 (defvar *var-counter
* 0)
36 (defun script-gensym (&optional
(name "js"))
37 (intern (format nil
"tmp-~A-~A" name
(incf *var-counter
*)) #.
*package
*))
40 (defscriptmacro list
(&rest values
)
43 (defscriptmacro make-array
(&rest inits
)
44 `(new (*array
,@inits
)))
47 (define-script-special-form eval-when
(&rest args
)
48 "(eval-when form-language? (situation*) form*)
50 The given forms are evaluated only during the given SITUATION in the specified
51 FORM-LANGUAGE (either :lisp or :parenscript, def, defaulting to :lisp during
52 -toplevel and :parenscript during :execute). The accepted SITUATIONS are :execute,
53 :scan-toplevel. :scan-toplevel is the phase of compilation when function definitions
54 and the like are being added to the compilation environment. :execute is the phase when
55 the code is being evaluated by a Javascript engine."
56 (multiple-value-bind (body-language situations subforms
)
57 (process-eval-when-args args
)
58 ; (format t "~A~%~A~%"
59 ; (and (compiler-in-situation-p *compilation-environment* :compile-toplevel)
60 ; (find :compile-toplevel situations))
61 ; (compiler-in-situation-p *compilation-environment* :execute)
62 ; (find :execute situations))
64 ((and (compiler-in-situation-p *compilation-environment
* :compile-toplevel
)
65 (find :compile-toplevel situations
))
66 (error "Should never be processing eval-when :COMPILE-TOPLEVEL forms from here."))
68 ((and (compiler-in-situation-p *compilation-environment
* :execute
)
69 (find :execute situations
))
70 (when (eql body-language
:parenscript
)
71 (let ((form `(progn ,@subforms
)))
72 (format t
"Form: ~A~%" form
)
73 (compile-to-statement form
)))))))
76 (defscriptmacro defpackage
(name &rest options
)
77 "Defines a Parenscript package."
78 (labels ((opt-name (opt) (if (listp opt
) (car opt
) opt
)))
79 (let ((nicknames nil
) (lisp-package nil
) (secondary-lisp-packages nil
)
80 (exports nil
) (used-packages nil
) (documentation nil
))
83 (:lisp-package
(setf lisp-package
(second opt
)))
84 (:nicknames
(setf nicknames
(rest opt
)))
85 (:secondary-lisp-packages secondary-lisp-packages t
)
86 (:export
(setf exports
(rest opt
)))
87 (:use
(setf used-packages
(rest opt
)))
88 (:documentation
(setf documentation
(second opt
)))
89 (t (error "Unknown option in DEFPACKAGE: ~A" (opt-name opt
)))))
90 (format t
"Exports: ~A~%" exports
)
91 (create-script-package
92 *compilation-environment
*
95 :secondary-lisp-packages secondary-lisp-packages
96 :used-packages used-packages
97 :lisp-package lisp-package
99 :documentation documentation
)))
102 (defscriptmacro in-package
(package-designator)
103 "Changes the current script package in the parenscript compilation environment. This mostly
104 affects the reader and how it interns non-prefixed symbols"
105 (let ((script-package
106 (find-script-package package-designator
*compilation-environment
*)))
107 (when (null script-package
)
108 (error "~A does not designate any script package. Available script package: ~A"
110 (mapcar #'script-package-name
(comp-env-script-packages *compilation-environment
*))))
111 (setf (comp-env-current-package *compilation-environment
*)
115 (defscriptmacro case
(value &rest clauses
)
116 (labels ((make-clause (val body more
)
118 (append (mapcar #'list
(butlast val
))
119 (make-clause (first (last val
)) body more
)))
120 ((member val
'(t otherwise
))
121 (make-clause 'default body more
))
122 (more `((,val
,@body break
)))
123 (t `((,val
,@body
))))))
124 `(switch ,value
,@(mapcon #'(lambda (x)
125 (make-clause (car (first x
))
131 (define-script-special-form let
(decls &rest body
)
132 (let ((defvars (mapcar #'(lambda (decl)
134 (make-instance 'ps-js
::js-defvar
135 :names
(list (compile-to-symbol decl
))
137 (let ((name (first decl
))
138 (value (second decl
)))
139 (make-instance 'ps-js
::js-defvar
140 :names
(list (compile-to-symbol name
))
141 :value
(compile-to-expression value
)))))
143 (make-instance 'ps-js
::js-sub-block
145 :statements
(nconc defvars
146 (mapcar #'compile-to-statement body
)))))
149 (defscriptmacro dotimes
(iter &rest body
)
150 (let ((var (first iter
))
151 (times (second iter
)))
152 `(do ((,var
0 (1+ ,var
)))
156 (defscriptmacro dolist
(i-array &rest body
)
157 (let ((var (first i-array
))
158 (array (second i-array
))
159 (arrvar (script-gensym "arr"))
160 (idx (script-gensym "i")))
161 `(let ((,arrvar
,array
))
162 (do ((,idx
0 (1+ ,idx
)))
163 ((>= ,idx
(slot-value ,arrvar
'length
)))
164 (let ((,var
(aref ,arrvar
,idx
)))
168 (defmacro with-temp-macro-environment
((var) &body body
)
169 `(let* ((,var
(make-macro-env-dictionary))
170 (*script-macro-env
* (cons ,var
*script-macro-env
*)))
173 (define-script-special-form macrolet
(macros &body body
)
174 (with-temp-macro-environment (macro-env-dict)
175 (dolist (macro macros
)
176 (destructuring-bind (name arglist
&body body
)
178 (setf (get-macro-spec name macro-env-dict
)
179 (cons nil
(let ((args (gensym "ps-macrolet-args-")))
180 (compile nil
`(lambda (&rest
,args
)
181 (destructuring-bind ,arglist
184 (compile-script-form `(progn ,@body
))))
186 (define-script-special-form symbol-macrolet
(symbol-macros &body body
)
187 (with-temp-macro-environment (macro-env-dict)
188 (dolist (macro symbol-macros
)
189 (destructuring-bind (name &body expansion
)
191 (setf (get-macro-spec name macro-env-dict
)
192 (cons t
(compile nil
`(lambda () ,@expansion
))))))
193 (compile-script-form `(progn ,@body
))))
195 (defscriptmacro defmacro
(name args
&body body
)
196 `(lisp (defscriptmacro ,name
,args
,@body
) nil
))
198 (defscriptmacro lisp
(&body forms
)
199 "Evaluates the given forms in Common Lisp at ParenScript
200 macro-expansion time. The value of the last form is treated as a
201 ParenScript expression and is inserted into the generated Javascript
202 (use nil for no-op)."
203 (eval (cons 'progn forms
)))
206 (defscriptmacro rebind
(variables expression
)
207 "Creates a new js lexical environment and copies the given
208 variable(s) there. Executes the body in the new environment. This
209 has the same effect as a new (let () ...) form in lisp but works on
210 the js side for js closures."
211 (unless (listp variables
)
212 (setf variables
(list variables
)))
214 (let ((new-context (new *object
)))
215 ,@(loop for variable in variables
216 do
(setf variable
(symbol-to-js variable
))
217 collect
`(setf (slot-value new-context
,variable
) (slot-value this
,variable
)))
219 (return ,expression
))))))