bulk of package system, reader, and other refactoring
[clinton/parenscript.git] / src / ps-macrology.lisp
1 (in-package :parenscript)
2
3 ;;;; The macrology of the Parenscript language. Special forms and macros.
4
5 ;;; parenscript gensyms
6 (defvar *gen-script-name-counter* 0)
7
8 (defun gen-script-name-string (&key (prefix "_js_"))
9 "Generates a unique valid javascript identifier ()"
10 (concatenate 'string
11 prefix (princ-to-string (incf *gen-script-name-counter*))))
12
13 (defun gen-script-name (&key (prefix "_ps_"))
14 "Generate a new javascript identifier."
15 (intern (gen-script-name-string :prefix prefix)
16 (find-package :js)))
17
18 (defmacro with-unique-js-names (symbols &body body)
19 "Evaluate BODY with the variables on SYMBOLS bound to new javascript identifiers.
20
21 Each element of SYMBOLS is either a symbol or a list of (symbol
22 prefix)."
23 `(let* ,(mapcar (lambda (symbol)
24 (destructuring-bind (symbol &optional prefix)
25 (if (consp symbol)
26 symbol
27 (list symbol))
28 (if prefix
29 `(,symbol (gen-script-name :prefix ,prefix))
30 `(,symbol (gen-script-name)))))
31 symbols)
32 ,@body))
33
34 (defvar *var-counter* 0)
35
36 (defun script-gensym (&optional (name "js"))
37 (intern (format nil "tmp-~A-~A" name (incf *var-counter*)) #.*package*))
38
39 ;;; array literals
40 (defscriptmacro list (&rest values)
41 `(array ,@values))
42
43 (defscriptmacro make-array (&rest inits)
44 `(new (*array ,@inits)))
45
46 ;;; eval-when
47 (define-script-special-form eval-when (&rest args)
48 "(eval-when form-language? (situation*) form*)
49
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))
63 (cond
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."))
67
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)))))))
74
75 ;;; script packages
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))
81 (dolist (opt options)
82 (case (opt-name opt)
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*
92 :name name
93 :nicknames nicknames
94 :secondary-lisp-packages secondary-lisp-packages
95 :used-packages used-packages
96 :lisp-package lisp-package
97 :exports exports
98 :documentation documentation)))
99 `(progn))
100
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*))
106 `(progn))
107
108 (defscriptmacro case (value &rest clauses)
109 (labels ((make-clause (val body more)
110 (cond ((listp val)
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))
119 (cdr (first x))
120 (rest x)))
121 clauses))))
122
123 ;;; let
124 (define-script-special-form let (decls &rest body)
125 (let ((defvars (mapcar #'(lambda (decl)
126 (if (atom decl)
127 (make-instance 'ps-js::js-defvar
128 :names (list (compile-to-symbol decl))
129 :value nil)
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)))))
135 decls)))
136 (make-instance 'ps-js::js-sub-block
137 :indent " "
138 :statements (nconc defvars
139 (mapcar #'compile-to-statement body)))))
140
141 ;;; iteration
142 (defscriptmacro dotimes (iter &rest body)
143 (let ((var (first iter))
144 (times (second iter)))
145 `(do ((,var 0 (1+ ,var)))
146 ((>= ,var ,times))
147 ,@body)))
148
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)))
158 ,@body)))))
159
160 ;;; macros
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*)))
164 ,@body))
165
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)
170 macro
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
175 ,args
176 ,@body))))))))
177 (compile-script-form `(progn ,@body))))
178
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)
183 macro
184 (setf (get-macro-spec name macro-env-dict)
185 (cons t (compile nil `(lambda () ,@expansion))))))
186 (compile-script-form `(progn ,@body))))
187
188 (defscriptmacro defmacro (name args &body body)
189 `(lisp (defscriptmacro ,name ,args ,@body) nil))
190
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)))
197
198
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)))
206 `((lambda ()
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)))
211 (with new-context
212 (return ,expression))))))