1 ;;; Naive Javascript unparser
3 ;;; This code generator takes as input a S-expression representation
4 ;;; of the Javascript AST and generates Javascript code without
5 ;;; redundant syntax constructions like extra parenthesis.
7 ;;; It is intended to be used with the new compiler. However, it is
8 ;;; quite independent so it has been integrated early in JSCL.
10 (defun ensure-list (x)
15 (defun concat (&rest strs)
16 (apply #'concatenate 'string strs))
18 (defmacro while (condition &body body)
23 (defvar *js-output* t)
25 ;;; Two seperate functions are needed for escaping strings:
26 ;;; One for producing JavaScript string literals (which are singly or
28 ;;; And one for producing Lisp strings (which are only doubly quoted)
30 ;;; The same function would suffice for both, but for javascript string
31 ;;; literals it is neater to use either depending on the context, e.g:
34 ;;; which avoids having to escape quotes where possible
35 (defun js-escape-string (string)
37 (size (length string))
38 (seen-single-quote nil)
39 (seen-double-quote nil))
40 (flet ((%js-escape-string (string escape-single-quote-p)
44 (let ((ch (char string index)))
46 (setq output (concat output "\\")))
47 (when (and escape-single-quote-p (char= ch #\'))
48 (setq output (concat output "\\")))
49 (when (char= ch #\newline)
50 (setq output (concat output "\\"))
52 (setq output (concat output (string ch))))
55 ;; First, scan the string for single/double quotes
57 (let ((ch (char string index)))
59 (setq seen-single-quote t))
61 (setq seen-double-quote t)))
63 ;; Then pick the appropriate way to escape the quotes
65 ((not seen-single-quote)
66 (concat "'" (%js-escape-string string nil) "'"))
67 ((not seen-double-quote)
68 (concat "\"" (%js-escape-string string nil) "\""))
69 (t (concat "'" (%js-escape-string string t) "'"))))))
72 (defun js-format (fmt &rest args)
73 (apply #'format *js-output* fmt args))
75 (defun valid-js-identifier (string-designator)
76 (let ((string (typecase string-designator
77 (symbol (string-downcase (symbol-name string-designator)))
78 (string string-designator)
80 (return-from valid-js-identifier (values nil nil))))))
81 (flet ((constitutentp (ch)
82 (or (alphanumericp ch) (member ch '(#\$ #\_)))))
83 (if (and (every #'constitutentp string)
84 (if (plusp (length string))
85 (not (digit-char-p (char string 0)))
87 (values (format nil "~a" string) t)
90 (defun js-identifier (string-designator)
91 (multiple-value-bind (string valid)
92 (valid-js-identifier string-designator)
94 (error "~S is not a valid Javascript identifier." string))
95 (js-format "~a" string)))
97 (defun js-primary-expr (form)
100 (js-format "~a" form))
102 (js-format "~a" (js-escape-string form)))
105 (true (js-format "true"))
106 (false (js-format "false"))
107 (null (js-format "null"))
108 (this (js-format "this"))
110 (js-identifier form))))
112 (error "Unknown Javascript syntax ~S." form))))
114 (defun js-vector-initializer (vector)
115 (let ((size (length vector)))
117 (dotimes (i (1- size))
118 (let ((elt (aref vector i)))
119 (unless (eq elt 'null)
123 (js-expr (aref vector (1- size))))
126 (defun js-object-initializer (plist)
128 (do* ((tail plist (cddr tail)))
130 (let ((key (car tail))
132 (multiple-value-bind (identifier identifier-p) (valid-js-identifier key)
133 (declare (ignore identifier))
136 (js-expr (string key))))
139 (unless (null (cddr tail))
143 (defun js-function (arguments &rest body)
144 (js-format "function(")
146 (js-identifier (car arguments))
147 (dolist (arg (cdr arguments))
149 (js-identifier arg)))
151 (js-stmt `(group ,@body)))
153 (defun check-lvalue (x)
154 (unless (or (symbolp x)
155 (nth-value 1 (valid-js-identifier x))
157 (member (car x) '(get =))))
158 (error "Bad Javascript lvalue ~S" x)))
160 ;;; Process the Javascript AST to reduce some syntax sugar.
161 (defun js-expand-expr (form)
165 (case (length (cdr form))
166 (1 `(unary+ ,(cadr form)))
167 (t (reduce (lambda (x y) `(+ ,x ,y)) (cdr form)))))
169 (case (length (cdr form))
170 (1 `(unary- ,(cadr form)))
171 (t (reduce (lambda (x y) `(- ,x ,y)) (cdr form)))))
173 (reduce (lambda (x y) `(comma ,x ,y)) (cdr form) :from-end t))
177 ;; Initialized to any value larger than any operator precedence
178 (defvar *js-operator-precedence* 1000)
179 (defvar *js-operator-associativity* 'left)
180 (defvar *js-operand-order* 'left)
182 ;; Format an expression optionally wrapped with parenthesis if the
183 ;; precedence rules require it.
184 (defmacro with-operator ((precedence associativity) &body body)
185 (let ((g!parens (gensym))
186 (g!precedence (gensym)))
187 `(let* ((,g!precedence ,precedence)
190 ((> ,g!precedence *js-operator-precedence*))
191 ((< ,g!precedence *js-operator-precedence*) nil)
192 ;; Same precedence. Let us consider associativity.
194 (not (eq *js-operand-order* *js-operator-associativity*)))))
195 (*js-operator-precedence* ,g!precedence)
196 (*js-operator-associativity* ,associativity)
197 (*js-operand-order* 'left))
198 (when ,g!parens (js-format "("))
200 (when ,g!parens (js-format ")")))))
202 (defun js-operator (string)
203 (js-format "~a" string)
204 (setq *js-operand-order* 'right))
206 (defun js-operator-expression (op args)
207 (let ((op1 (car args))
215 (with-operator (13 'left)
216 (js-expr (cadr args))
217 (dolist (operand (cddr args))
218 (let ((*js-output* t))
220 (js-expr operand)))))
224 (multiple-value-bind (identifier identifierp)
225 (valid-js-identifier (car args))
226 (multiple-value-bind (accessor accessorp)
227 (valid-js-identifier (cadr args))
229 ((and identifierp accessorp)
230 (js-identifier identifier)
232 (js-identifier accessor))
236 (js-expr (cadr args))
240 (js-object-initializer args))
241 ;; Function expressions
244 (apply #'js-function args)
247 (flet ((%unary-op (operator string precedence associativity post lvalue)
248 (when (eq op operator)
249 (with-operator (precedence associativity)
250 (when lvalue (check-lvalue op1))
254 (js-operator string))
258 (return-from js-operator-expression)))
259 (%binary-op (operator string precedence associativity lvalue)
260 (when (eq op operator)
261 (when lvalue (check-lvalue op1))
262 (with-operator (precedence associativity)
266 (return-from js-operator-expression))))
268 (macrolet ((unary-op (operator string precedence associativity &key post lvalue)
269 `(%unary-op ',operator ',string ',precedence ',associativity ',post ',lvalue))
270 (binary-op (operator string precedence associativity &key lvalue)
271 `(%binary-op ',operator ',string ',precedence ',associativity ',lvalue)))
273 (unary-op pre++ "++" 1 right :lvalue t)
274 (unary-op pre-- "--" 1 right :lvalue t)
275 (unary-op post++ "++" 1 right :lvalue t :post t)
276 (unary-op post-- "--" 1 right :lvalue t :post t)
277 (unary-op not-- "!" 1 right)
278 (unary-op unary+ "+" 1 right)
279 (unary-op unary- "-" 1 right)
280 (unary-op delete "delete " 1 right)
281 (unary-op void "void " 1 right)
282 (unary-op typeof "typeof " 1 right)
283 (unary-op new "new " 1 right)
285 (binary-op * "*" 2 left)
286 (binary-op / "/" 2 left)
287 (binary-op mod "%" 2 left)
288 (binary-op % "%" 2 left)
289 (binary-op + "+" 3 left)
290 (binary-op - "-" 3 left)
291 (binary-op << "<<" 4 left)
292 (binary-op >> "<<" 4 left)
293 (binary-op >>> ">>>" 4 left)
294 (binary-op <= "<=" 5 left)
295 (binary-op < "<" 5 left)
296 (binary-op > ">" 5 left)
297 (binary-op >= ">=" 5 left)
298 (binary-op instanceof " instanceof " 5 left)
299 (binary-op in " in " 5 left)
300 (binary-op == "==" 6 left)
301 (binary-op != "!=" 6 left)
302 (binary-op === "===" 6 left)
303 (binary-op !== "!==" 6 left)
304 (binary-op bit-and "&" 7 left)
305 (binary-op bit-xor "^" 8 left)
306 (binary-op bit-or "|" 9 left)
307 (binary-op and "&&" 10 left)
308 (binary-op or "||" 11 left)
309 (binary-op = "=" 13 right :lvalue t)
310 (binary-op += "+=" 13 right :lvalue t)
311 (binary-op incf "+=" 13 right :lvalue t)
312 (binary-op -= "-=" 13 right :lvalue t)
313 (binary-op decf "-=" 13 right :lvalue t)
314 (binary-op *= "*=" 13 right :lvalue t)
315 (binary-op /= "*=" 13 right :lvalue t)
316 (binary-op bit-xor= "^=" 13 right :lvalue t)
317 (binary-op bit-and= "&=" 13 right :lvalue t)
318 (binary-op bit-or= "|=" 13 right :lvalue t)
319 (binary-op <<= "<<=" 13 right :lvalue t)
320 (binary-op >>= ">>=" 13 right :lvalue t)
321 (binary-op >>>= ">>>=" 13 right :lvalue t)
323 (binary-op comma "," 13 right)
324 (binary-op progn "," 13 right)
326 (when (member op '(? if))
327 (with-operator (12 'right)
328 (js-expr (first args))
330 (js-expr (second args))
332 (js-expr (third args))))))))))
334 (defun js-expr (form)
335 (let ((form (js-expand-expr form)))
337 ((or (symbolp form) (numberp form) (stringp form))
338 (js-primary-expr form))
340 (js-vector-initializer form))
342 (js-operator-expression (car form) (cdr form))))))
344 (defun js-stmt (form)
351 (destructuring-bind (label &body body) (cdr form)
352 (js-identifier label)
354 (js-stmt `(progn ,@body))))
356 (destructuring-bind (label) (cdr form)
358 (js-identifier label)
361 (destructuring-bind (value) (cdr form)
362 (js-format "return ")
366 (flet ((js-var (spec)
367 (destructuring-bind (variable &optional initial)
369 (js-identifier variable)
372 (js-expr initial)))))
373 (destructuring-bind (var &rest vars) (cdr form)
374 (let ((*js-operator-precedence* 12))
382 (destructuring-bind (condition true &optional false) (cdr form)
392 (mapc #'js-stmt (cdr form))
399 (js-stmt (cadr form)))
401 (js-stmt `(group ,@(cdr form))))))
403 (destructuring-bind (condition &body body) (cdr form)
404 (js-format "while (")
407 (js-stmt `(group ,@body))))
412 (defun js (&rest stmts)
413 (mapc #'js-stmt stmts))