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 (create-script-package
91 *compilation-environment
*
94 :secondary-lisp-packages secondary-lisp-packages
95 :used-packages used-packages
96 :lisp-package lisp-package
98 :documentation documentation
)))
101 (defscriptmacro in-package
(package-designator)
102 "Changes the current script package in the parenscript compilation environment. This mostly
103 affects the reader and how it interns non-prefixed symbols"
104 (setf (comp-env-current-package *compilation-environment
*)
105 (find-script-package package-designator
*compilation-environment
*))
108 (defscriptmacro case
(value &rest clauses
)
109 (labels ((make-clause (val body more
)
111 (append (mapcar #'list
(butlast val
))
112 (make-clause (first (last val
)) body more
)))
113 ((member val
'(t otherwise
))
114 (make-clause 'default body more
))
115 (more `((,val
,@body break
)))
116 (t `((,val
,@body
))))))
117 `(switch ,value
,@(mapcon #'(lambda (x)
118 (make-clause (car (first x
))
124 (define-script-special-form let
(decls &rest body
)
125 (let ((defvars (mapcar #'(lambda (decl)
127 (make-instance 'ps-js
::js-defvar
128 :names
(list (compile-to-symbol decl
))
130 (let ((name (first decl
))
131 (value (second decl
)))
132 (make-instance 'ps-js
::js-defvar
133 :names
(list (compile-to-symbol name
))
134 :value
(compile-to-expression value
)))))
136 (make-instance 'ps-js
::js-sub-block
138 :statements
(nconc defvars
139 (mapcar #'compile-to-statement body
)))))
142 (defscriptmacro dotimes
(iter &rest body
)
143 (let ((var (first iter
))
144 (times (second iter
)))
145 `(do ((,var
0 (1+ ,var
)))
149 (defscriptmacro dolist
(i-array &rest body
)
150 (let ((var (first i-array
))
151 (array (second i-array
))
152 (arrvar (script-gensym "arr"))
153 (idx (script-gensym "i")))
154 `(let ((,arrvar
,array
))
155 (do ((,idx
0 (1+ ,idx
)))
156 ((>= ,idx
(slot-value ,arrvar
'length
)))
157 (let ((,var
(aref ,arrvar
,idx
)))
161 (defmacro with-temp-macro-environment
((var) &body body
)
162 `(let* ((,var
(make-macro-env-dictionary))
163 (*script-macro-env
* (cons ,var
*script-macro-env
*)))
166 (define-script-special-form macrolet
(macros &body body
)
167 (with-temp-macro-environment (macro-env-dict)
168 (dolist (macro macros
)
169 (destructuring-bind (name arglist
&body body
)
171 (setf (get-macro-spec name macro-env-dict
)
172 (cons nil
(let ((args (gensym "ps-macrolet-args-")))
173 (compile nil
`(lambda (&rest
,args
)
174 (destructuring-bind ,arglist
177 (compile-script-form `(progn ,@body
))))
179 (define-script-special-form symbol-macrolet
(symbol-macros &body body
)
180 (with-temp-macro-environment (macro-env-dict)
181 (dolist (macro symbol-macros
)
182 (destructuring-bind (name &body expansion
)
184 (setf (get-macro-spec name macro-env-dict
)
185 (cons t
(compile nil
`(lambda () ,@expansion
))))))
186 (compile-script-form `(progn ,@body
))))
188 (defscriptmacro defmacro
(name args
&body body
)
189 `(lisp (defscriptmacro ,name
,args
,@body
) nil
))
191 (defscriptmacro lisp
(&body forms
)
192 "Evaluates the given forms in Common Lisp at ParenScript
193 macro-expansion time. The value of the last form is treated as a
194 ParenScript expression and is inserted into the generated Javascript
195 (use nil for no-op)."
196 (eval (cons 'progn forms
)))
199 (defscriptmacro rebind
(variables expression
)
200 "Creates a new js lexical environment and copies the given
201 variable(s) there. Executes the body in the new environment. This
202 has the same effect as a new (let () ...) form in lisp but works on
203 the js side for js closures."
204 (unless (listp variables
)
205 (setf variables
(list variables
)))
207 (let ((new-context (new *object
)))
208 ,@(loop for variable in variables
209 do
(setf variable
(symbol-to-js variable
))
210 collect
`(setf (slot-value new-context
,variable
) (slot-value this
,variable
)))
212 (return ,expression
))))))