1 ;;; compiler-codege.lisp --- Naive Javascript unparser
3 ;; copyright (C) 2013 David Vazquez
5 ;; JSCL is free software: you can redistribute it and/or
6 ;; modify it under the terms of the GNU General Public License as
7 ;; published by the Free Software Foundation, either version 3 of the
8 ;; License, or (at your option) any later version.
10 ;; JSCL is distributed in the hope that it will be useful, but
11 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;; General Public License for more details.
15 ;; You should have received a copy of the GNU General Public License
16 ;; along with JSCL. If not, see <http://www.gnu.org/licenses/>.
18 ;;; This code generator takes as input a S-expression representation
19 ;;; of the Javascript AST and generates Javascript code without
20 ;;; redundant syntax constructions like extra parenthesis.
22 ;;; It is intended to be used with the new compiler. However, it is
23 ;;; quite independent so it has been integrated early in JSCL.
25 (/debug "loading compiler-codegen.lisp!")
27 (defvar *js-output* t)
29 ;;; Two seperate functions are needed for escaping strings:
30 ;;; One for producing JavaScript string literals (which are singly or
32 ;;; And one for producing Lisp strings (which are only doubly quoted)
34 ;;; The same function would suffice for both, but for javascript string
35 ;;; literals it is neater to use either depending on the context, e.g:
38 ;;; which avoids having to escape quotes where possible
39 (defun js-escape-string (string)
41 (size (length string))
42 (seen-single-quote nil)
43 (seen-double-quote nil))
44 (flet ((%js-escape-string (string escape-single-quote-p)
48 (let ((ch (char string index)))
50 (setq output (concat output "\\")))
51 (when (and escape-single-quote-p (char= ch #\'))
52 (setq output (concat output "\\")))
53 (when (char= ch #\newline)
54 (setq output (concat output "\\"))
56 (setq output (concat output (string ch))))
59 ;; First, scan the string for single/double quotes
61 (let ((ch (char string index)))
63 (setq seen-single-quote t))
65 (setq seen-double-quote t)))
67 ;; Then pick the appropriate way to escape the quotes
69 ((not seen-single-quote)
70 (concat "'" (%js-escape-string string nil) "'"))
71 ((not seen-double-quote)
72 (concat "\"" (%js-escape-string string nil) "\""))
73 (t (concat "'" (%js-escape-string string t) "'"))))))
76 (defun js-format (fmt &rest args)
77 (apply #'format *js-output* fmt args))
79 (defun valid-js-identifier (string-designator)
80 (let ((string (typecase string-designator
81 (symbol (symbol-name string-designator))
82 (string string-designator)
84 (return-from valid-js-identifier (values nil nil))))))
85 (flet ((constitutentp (ch)
86 (or (alphanumericp ch) (member ch '(#\$ #\_)))))
87 (if (and (every #'constitutentp string)
88 (if (plusp (length string))
89 (not (digit-char-p (char string 0)))
91 (values (format nil "~a" string) t)
94 (defun js-identifier (string-designator)
95 (multiple-value-bind (string valid)
96 (valid-js-identifier string-designator)
98 (error "~S is not a valid Javascript identifier." string))
99 (js-format "~a" string)))
101 (defun js-primary-expr (form)
105 (js-format "~a" form)
106 (js-expr `(- ,(abs form)))))
108 (js-format "~a" (js-escape-string form)))
111 (true (js-format "true"))
112 (false (js-format "false"))
113 (null (js-format "null"))
114 (this (js-format "this"))
115 (undefined (js-format "undefined"))
117 (js-identifier form))))
119 (error "Unknown Javascript syntax ~S." form))))
121 (defun js-vector-initializer (vector)
122 (let ((size (length vector)))
124 (dotimes (i (1- size))
125 (let ((elt (aref vector i)))
126 (unless (eq elt 'null)
130 (js-expr (aref vector (1- size))))
133 (defun js-object-initializer (plist)
135 (do* ((tail plist (cddr tail)))
137 (let ((key (car tail))
139 (multiple-value-bind (identifier identifier-p) (valid-js-identifier key)
140 (declare (ignore identifier))
143 (js-expr (string key))))
146 (unless (null (cddr tail))
150 (defun js-function (arguments &rest body)
151 (js-format "function(")
153 (js-identifier (car arguments))
154 (dolist (arg (cdr arguments))
156 (js-identifier arg)))
158 (js-stmt `(group ,@body) t))
160 (defun check-lvalue (x)
161 (unless (or (symbolp x)
162 (nth-value 1 (valid-js-identifier x))
164 (member (car x) '(get = property))))
165 (error "Bad Javascript lvalue ~S" x)))
167 ;;; Process the Javascript AST to reduce some syntax sugar.
168 (defun js-expand-expr (form)
172 (case (length (cdr form))
173 (1 `(unary+ ,(cadr form)))
174 (t (reduce (lambda (x y) `(+ ,x ,y)) (cdr form)))))
176 (case (length (cdr form))
177 (1 `(unary- ,(cadr form)))
178 (t (reduce (lambda (x y) `(- ,x ,y)) (cdr form)))))
180 (reduce (lambda (x y) `(comma ,x ,y)) (cdr form) :from-end t))
184 ;; Initialized to any value larger than any operator precedence
185 (defvar *js-operator-precedence* 1000)
186 (defvar *js-operator-associativity* 'left)
187 (defvar *js-operand-order* 'left)
189 ;; Format an expression optionally wrapped with parenthesis if the
190 ;; precedence rules require it.
191 (defmacro with-operator ((precedence associativity) &body body)
192 (let ((g!parens (gensym))
193 (g!precedence (gensym)))
194 `(let* ((,g!precedence ,precedence)
197 ((> ,g!precedence *js-operator-precedence*))
198 ((< ,g!precedence *js-operator-precedence*) nil)
199 ;; Same precedence. Let us consider associativity.
201 (not (eq *js-operand-order* *js-operator-associativity*)))))
202 (*js-operator-precedence* ,g!precedence)
203 (*js-operator-associativity* ,associativity)
204 (*js-operand-order* 'left))
205 (when ,g!parens (js-format "("))
207 (when ,g!parens (js-format ")")))))
209 (defun js-operator (string)
210 (js-format "~a" string)
211 (setq *js-operand-order* 'right))
213 (defun js-operator-expression (op args)
214 (let ((op1 (car args))
217 ;; Transactional compatible operator
219 (js-format "~a" (apply #'code args)))
225 (with-operator (12 'left)
226 (js-expr (cadr args))
227 (dolist (operand (cddr args))
228 (let ((*js-output* t))
230 (js-expr operand)))))
236 (js-expr (cadr args))
239 (multiple-value-bind (identifier identifierp)
240 (valid-js-identifier (car args))
241 (multiple-value-bind (accessor accessorp)
242 (valid-js-identifier (cadr args))
244 ((and identifierp accessorp)
245 (js-identifier identifier)
247 (js-identifier accessor))
251 (js-expr (cadr args))
255 (js-object-initializer args))
256 ;; Function expressions
259 (apply #'js-function args)
262 (flet ((%unary-op (operator string precedence associativity post lvalue)
263 (when (eq op operator)
264 (with-operator (precedence associativity)
265 (when lvalue (check-lvalue op1))
269 (js-operator string))
273 (return-from js-operator-expression)))
274 (%binary-op (operator string precedence associativity lvalue)
275 (when (eq op operator)
276 (when lvalue (check-lvalue op1))
277 (with-operator (precedence associativity)
281 (return-from js-operator-expression))))
283 (macrolet ((unary-op (operator string precedence associativity &key post lvalue)
284 `(%unary-op ',operator ',string ',precedence ',associativity ',post ',lvalue))
285 (binary-op (operator string precedence associativity &key lvalue)
286 `(%binary-op ',operator ',string ',precedence ',associativity ',lvalue)))
288 (unary-op pre++ "++" 1 right :lvalue t)
289 (unary-op pre-- "--" 1 right :lvalue t)
290 (unary-op post++ "++" 1 right :lvalue t :post t)
291 (unary-op post-- "--" 1 right :lvalue t :post t)
292 (unary-op not "!" 1 right)
293 (unary-op bit-not "~" 1 right)
294 ;; Note that the leading space is necessary because it
295 ;; could break with post++, for example. TODO: Avoid
296 ;; leading space when it's possible.
297 (unary-op unary+ " +" 1 right)
298 (unary-op unary- " -" 1 right)
299 (unary-op delete "delete " 1 right)
300 (unary-op void "void " 1 right)
301 (unary-op typeof "typeof " 1 right)
302 (unary-op new "new " 1 right)
304 (binary-op * "*" 2 left)
305 (binary-op / "/" 2 left)
306 (binary-op mod "%" 2 left)
307 (binary-op % "%" 2 left)
308 (binary-op + "+" 3 left)
309 (binary-op - "-" 3 left)
310 (binary-op << "<<" 4 left)
311 (binary-op >> "<<" 4 left)
312 (binary-op >>> ">>>" 4 left)
313 (binary-op <= "<=" 5 left)
314 (binary-op < "<" 5 left)
315 (binary-op > ">" 5 left)
316 (binary-op >= ">=" 5 left)
317 (binary-op instanceof " instanceof " 5 left)
318 (binary-op in " in " 5 left)
319 (binary-op == "==" 6 left)
320 (binary-op != "!=" 6 left)
321 (binary-op === "===" 6 left)
322 (binary-op !== "!==" 6 left)
323 (binary-op bit-and "&" 7 left)
324 (binary-op bit-xor "^" 8 left)
325 (binary-op bit-or "|" 9 left)
326 (binary-op and "&&" 10 left)
327 (binary-op or "||" 11 left)
328 (binary-op = "=" 13 right :lvalue t)
329 (binary-op += "+=" 13 right :lvalue t)
330 (binary-op incf "+=" 13 right :lvalue t)
331 (binary-op -= "-=" 13 right :lvalue t)
332 (binary-op decf "-=" 13 right :lvalue t)
333 (binary-op *= "*=" 13 right :lvalue t)
334 (binary-op /= "*=" 13 right :lvalue t)
335 (binary-op bit-xor= "^=" 13 right :lvalue t)
336 (binary-op bit-and= "&=" 13 right :lvalue t)
337 (binary-op bit-or= "|=" 13 right :lvalue t)
338 (binary-op <<= "<<=" 13 right :lvalue t)
339 (binary-op >>= ">>=" 13 right :lvalue t)
340 (binary-op >>>= ">>>=" 13 right :lvalue t)
342 (binary-op comma "," 13 right)
343 (binary-op progn "," 13 right)
345 (when (member op '(? if))
346 (with-operator (12 'right)
347 (js-expr (first args))
349 (js-expr (second args))
351 (js-expr (third args)))
352 (return-from js-operator-expression))
354 (error "Unknown operator `~S'" op)))))))
356 (defun js-expr (form)
357 (let ((form (js-expand-expr form)))
359 ((or (symbolp form) (numberp form) (stringp form))
360 (js-primary-expr form))
362 (js-vector-initializer form))
364 (js-operator-expression (car form) (cdr form))))))
366 (defun js-expand-stmt (form)
368 ((and (consp form) (eq (car form) 'progn))
369 (destructuring-bind (&body body) (cdr form)
374 (js-expand-stmt (car body)))
376 `(group ,@(cdr form))))))
380 (defun js-stmt (form &optional parent)
381 (let ((form (js-expand-stmt form)))
382 (flet ((js-stmt (x) (js-stmt x form)))
385 (unless (or (and (consp parent) (eq (car parent) 'group))
395 (js-format "~a" (apply #'code (cdr form))))
397 (destructuring-bind (label &body body) (cdr form)
398 (js-identifier label)
400 (js-stmt `(progn ,@body))))
402 (destructuring-bind (label) (cdr form)
404 (js-identifier label)
407 (destructuring-bind (value) (cdr form)
408 (js-format "return ")
412 (flet ((js-var (spec)
413 (destructuring-bind (variable &optional initial)
415 (js-identifier variable)
418 (js-expr initial)))))
419 (destructuring-bind (var &rest vars) (cdr form)
420 (let ((*js-operator-precedence* 12))
428 (destructuring-bind (condition true &optional false) (cdr form)
439 (and (consp parent) (eq (car parent) 'group)))))
440 (unless in-group-p (js-format "{"))
441 (mapc #'js-stmt (cdr form))
442 (unless in-group-p (js-format "}"))))
444 (destructuring-bind (condition &body body) (cdr form)
445 (js-format "while (")
448 (js-stmt `(progn ,@body))))
450 (destructuring-bind (&rest body) (cdr form)
452 (js-stmt `(group ,@body))))
454 (destructuring-bind ((var) &rest body) (cdr form)
455 (js-format "catch (")
458 (js-stmt `(group ,@body))))
460 (destructuring-bind (&rest body) (cdr form)
461 (js-format "finally")
462 (js-stmt `(group ,@body))))
464 (destructuring-bind (object) (cdr form)
470 (js-format ";"))))))))
472 (defun js (&rest stmts)
473 (mapc #'js-stmt stmts)