1 ;;; compiler-codege.lisp --- Naive Javascript unparser
3 ;; Copyright (C) 2013, 2014 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/>.
19 ;;; This code generator takes as input a S-expression representation
20 ;;; of the Javascript AST and generates Javascript code without
21 ;;; redundant syntax constructions like extra parenthesis.
23 ;;; It is intended to be used with the new compiler. However, it is
24 ;;; quite independent so it has been integrated early in JSCL.
26 (/debug "loading compiler-codegen.lisp!")
29 (defvar *js-macros* nil)
30 (defmacro define-js-macro (name lambda-list &body body)
31 (let ((form (gensym)))
35 (destructuring-bind ,lambda-list ,form
39 (defun js-macroexpand (js)
40 (if (and (consp js) (assoc (car js) *js-macros*))
41 (let ((expander (cdr (assoc (car js) *js-macros*))))
42 (multiple-value-bind (expansion stop-expand-p)
43 (funcall expander (cdr js))
46 (js-macroexpand expansion))))
50 (defconstant no-comma 12)
52 (defvar *js-output* t)
54 (defvar *js-pretty-print* t)
56 ;;; Two seperate functions are needed for escaping strings:
57 ;;; One for producing JavaScript string literals (which are singly or
59 ;;; And one for producing Lisp strings (which are only doubly quoted)
61 ;;; The same function would suffice for both, but for javascript string
62 ;;; literals it is neater to use either depending on the context, e.g:
65 ;;; which avoids having to escape quotes where possible
66 (defun js-escape-string (string)
68 (size (length string))
69 (seen-single-quote nil)
70 (seen-double-quote nil))
71 (flet ((%js-escape-string (string escape-single-quote-p)
75 (let ((ch (char string index)))
77 (setq output (concat output "\\")))
78 (when (and escape-single-quote-p (char= ch #\'))
79 (setq output (concat output "\\")))
80 (when (char= ch #\newline)
81 (setq output (concat output "\\"))
83 (setq output (concat output (string ch))))
86 ;; First, scan the string for single/double quotes
88 (let ((ch (char string index)))
90 (setq seen-single-quote t))
92 (setq seen-double-quote t)))
94 ;; Then pick the appropriate way to escape the quotes
96 ((not seen-single-quote)
97 (concat "'" (%js-escape-string string nil) "'"))
98 ((not seen-double-quote)
99 (concat "\"" (%js-escape-string string nil) "\""))
100 (t (concat "'" (%js-escape-string string t) "'"))))))
103 (defun js-format (fmt &rest args)
104 (apply #'format *js-output* fmt args))
106 ;;; Check if STRING-DESIGNATOR is valid as a Javascript identifier. It
107 ;;; returns a couple of values. The identifier itself as a string and
108 ;;; a boolean value with the result of this check.
109 (defun valid-js-identifier (string-designator)
110 (let ((string (typecase string-designator
111 (symbol (symbol-name string-designator))
112 (string string-designator)
114 (return-from valid-js-identifier (values nil nil))))))
115 (flet ((constitutentp (ch)
116 (or (alphanumericp ch) (member ch '(#\$ #\_)))))
117 (if (and (every #'constitutentp string)
118 (if (plusp (length string))
119 (not (digit-char-p (char string 0)))
125 ;;; Expression generators
127 ;;; `js-expr' and the following auxiliary functions are the
128 ;;; responsible for generating Javascript expression.
130 (defun js-identifier (string-designator)
131 (multiple-value-bind (string valid)
132 (valid-js-identifier string-designator)
134 (error "~S is not a valid Javascript identifier." string))
135 (js-format "~a" string)))
137 (defun js-primary-expr (form)
141 (js-format "~a" form)
142 (js-expr `(- ,(abs form)))))
144 (js-format "~a" (js-escape-string form)))
147 (true (js-format "true"))
148 (false (js-format "false"))
149 (null (js-format "null"))
150 (this (js-format "this"))
151 (undefined (js-format "undefined"))
153 (js-identifier form))))
155 (error "Unknown Javascript syntax ~S." form))))
157 (defun js-vector-initializer (vector)
158 (let ((size (length vector)))
160 (dotimes (i (1- size))
161 (let ((elt (aref vector i)))
162 (unless (eq elt 'null)
163 (js-expr elt no-comma))
166 (js-expr (aref vector (1- size)) no-comma))
169 (defun js-object-initializer (plist)
171 (do* ((tail plist (cddr tail)))
173 (let ((key (car tail))
175 (multiple-value-bind (identifier identifier-p) (valid-js-identifier key)
176 (declare (ignore identifier))
179 (js-expr (string key) no-comma)))
181 (js-expr value no-comma)
182 (unless (null (cddr tail))
186 (defun js-function (arguments &rest body)
187 (js-format "function(")
189 (js-identifier (car arguments))
190 (dolist (arg (cdr arguments))
192 (js-identifier arg)))
194 (js-stmt `(group ,@body) t))
196 (defun check-lvalue (x)
197 (unless (or (symbolp x)
198 (nth-value 1 (valid-js-identifier x))
200 (member (car x) '(get = property))))
201 (error "Bad Javascript lvalue ~S" x)))
203 ;;; Process the Javascript AST to reduce some syntax sugar.
204 (defun js-expand-expr (form)
208 (case (length (cdr form))
209 (1 `(unary+ ,(cadr form)))
210 (t (reduce (lambda (x y) `(+ ,x ,y)) (cdr form)))))
212 (case (length (cdr form))
213 (1 `(unary- ,(cadr form)))
214 (t (reduce (lambda (x y) `(- ,x ,y)) (cdr form)))))
216 (case (length (cdr form))
218 (t (reduce (lambda (x y) `(* ,x ,y)) (cdr form)))))
220 (reduce (lambda (x y) `(,(car form) ,x ,y)) (cdr form)))
222 (reduce (lambda (x y) `(comma ,x ,y)) (cdr form) :from-end t))
224 (js-macroexpand form)))
227 ;;; It is the more complicated function of the generator. It takes a
228 ;;; operator expression and generate Javascript for it. It will
229 ;;; consider associativity and precedence in order not to generate
230 ;;; unnecessary parenthesis.
231 (defun js-operator-expression (op args precedence associativity operand-order)
232 (let ((op1 (car args))
237 (js-expr (car args) 0)
239 (js-expr (cadr args) no-comma)
242 (multiple-value-bind (accessor accessorp)
243 (valid-js-identifier (cadr args))
245 (error "Invalid accessor ~S" (cadr args)))
246 (js-expr (car args) 0)
248 (js-identifier accessor)))
251 (js-expr (car args) 1)
254 (js-expr (cadr args) no-comma)
255 (dolist (operand (cddr args))
257 (js-expr operand no-comma)))
261 (js-object-initializer args))
262 ;; Function expressions
265 (apply #'js-function args)
268 (labels ((low-precedence-p (op-precedence)
270 ((> op-precedence precedence))
271 ((< op-precedence precedence) nil)
272 (t (not (eq operand-order associativity)))))
274 (%unary-op (operator string operator-precedence operator-associativity post lvalue)
275 (when (eq op operator)
276 (when lvalue (check-lvalue op1))
277 (when (low-precedence-p operator-precedence) (js-format "("))
280 (js-expr op1 operator-precedence operator-associativity 'left)
281 (js-format "~a" string))
283 (js-format "~a" string)
284 (js-expr op1 operator-precedence operator-associativity 'right)))
285 (when (low-precedence-p operator-precedence) (js-format ")"))
286 (return-from js-operator-expression)))
288 (%binary-op (operator string operator-precedence operator-associativity lvalue)
289 (when (eq op operator)
290 (when lvalue (check-lvalue op1))
291 (when (low-precedence-p operator-precedence) (js-format "("))
292 (js-expr op1 operator-precedence operator-associativity 'left)
293 (js-format "~a" string)
294 (js-expr op2 operator-precedence operator-associativity 'right)
295 (when (low-precedence-p operator-precedence) (js-format ")"))
296 (return-from js-operator-expression))))
298 (macrolet ((unary-op (operator string precedence associativity &key post lvalue)
299 `(%unary-op ',operator ',string ',precedence ',associativity ',post ',lvalue))
300 (binary-op (operator string precedence associativity &key lvalue)
301 `(%binary-op ',operator ',string ',precedence ',associativity ',lvalue)))
303 (unary-op pre++ "++" 2 right :lvalue t)
304 (unary-op pre-- "--" 2 right :lvalue t)
305 (unary-op post++ "++" 2 right :lvalue t :post t)
306 (unary-op post-- "--" 2 right :lvalue t :post t)
307 (unary-op not "!" 2 right)
308 (unary-op bit-not "~" 2 right)
309 ;; Note that the leading space is necessary because it
310 ;; could break with post++, for example. TODO: Avoid
311 ;; leading space when it's possible.
312 (unary-op unary+ " +" 2 right)
313 (unary-op unary- " -" 2 right)
314 (unary-op delete "delete " 2 right)
315 (unary-op void "void " 2 right)
316 (unary-op typeof "typeof " 2 right)
317 (unary-op new "new " 2 right)
319 (binary-op * "*" 3 left)
320 (binary-op / "/" 3 left)
321 (binary-op mod "%" 3 left)
322 (binary-op % "%" 3 left)
323 (binary-op + "+" 4 left)
324 (binary-op - "-" 5 left)
325 (binary-op << "<<" 5 left)
326 (binary-op >> "<<" 5 left)
327 (binary-op >>> ">>>" 5 left)
328 (binary-op <= "<=" 6 left)
329 (binary-op < "<" 6 left)
330 (binary-op > ">" 6 left)
331 (binary-op >= ">=" 6 left)
332 (binary-op instanceof " instanceof " 6 left)
333 (binary-op in " in " 6 left)
334 (binary-op == "==" 7 left)
335 (binary-op != "!=" 7 left)
336 (binary-op === "===" 7 left)
337 (binary-op !== "!==" 7 left)
338 (binary-op bit-and "&" 8 left)
339 (binary-op bit-xor "^" 9 left)
340 (binary-op bit-or "|" 10 left)
341 (binary-op and "&&" 11 left)
342 (binary-op or "||" 12 left)
343 (binary-op = "=" 13 right :lvalue t)
344 (binary-op += "+=" 13 right :lvalue t)
345 (binary-op incf "+=" 13 right :lvalue t)
346 (binary-op -= "-=" 13 right :lvalue t)
347 (binary-op decf "-=" 13 right :lvalue t)
348 (binary-op *= "*=" 13 right :lvalue t)
349 (binary-op /= "*=" 13 right :lvalue t)
350 (binary-op bit-xor= "^=" 13 right :lvalue t)
351 (binary-op bit-and= "&=" 13 right :lvalue t)
352 (binary-op bit-or= "|=" 13 right :lvalue t)
353 (binary-op <<= "<<=" 13 right :lvalue t)
354 (binary-op >>= ">>=" 13 right :lvalue t)
355 (binary-op >>>= ">>>=" 13 right :lvalue t)
357 (binary-op comma "," 13 right)
358 (binary-op progn "," 13 right)
360 (when (member op '(? if))
361 (when (low-precedence-p 12) (js-format "("))
362 (js-expr (first args) 12 'right 'left)
364 (js-expr (second args) 12 'right 'right)
366 (js-expr (third args) 12 'right 'right)
367 (when (low-precedence-p 12) (js-format ")"))
368 (return-from js-operator-expression))
370 (error "Unknown operator `~S'" op)))))))
372 (defun js-expr (form &optional (precedence 1000) associativity operand-order)
373 (let ((form (js-expand-expr form)))
375 ((or (symbolp form) (numberp form) (stringp form))
376 (js-primary-expr form))
378 (js-vector-initializer form))
380 (js-operator-expression (car form) (cdr form) precedence associativity operand-order)))))
384 ;;; Statements generators
386 ;;; `js-stmt' generates code for Javascript statements. A form is
387 ;;; provided to label statements. Remember that in particular,
388 ;;; expressions can be used as statements (semicolon suffixed).
391 (defun js-expand-stmt (form)
393 ((and (consp form) (eq (car form) 'progn))
394 (destructuring-bind (&body body) (cdr form)
399 (js-expand-stmt (car body)))
401 `(group ,@(cdr form))))))
403 (js-macroexpand form))))
405 (defun js-end-stmt ()
407 (when *js-pretty-print*
410 (defun js-stmt (form &optional parent)
411 (let ((form (js-expand-stmt form)))
412 (flet ((js-stmt (x) (js-stmt x form)))
415 (unless (or (and (consp parent) (eq (car parent) 'group))
425 (destructuring-bind (label &body body) (cdr form)
426 (js-identifier label)
428 (js-stmt `(progn ,@body))))
430 (destructuring-bind (&optional label) (cdr form)
434 (js-identifier label))
437 (destructuring-bind (value) (cdr form)
438 (js-format "return ")
442 (flet ((js-var (spec)
443 (destructuring-bind (variable &optional initial)
445 (js-identifier variable)
448 (js-expr initial no-comma)))))
449 (destructuring-bind (var &rest vars) (cdr form)
457 (destructuring-bind (condition true &optional false) (cdr form)
468 (and (consp parent) (eq (car parent) 'group)))))
469 (unless in-group-p (js-format "{"))
470 (mapc #'js-stmt (cdr form))
471 (unless in-group-p (js-format "}"))))
473 (destructuring-bind (condition &body body) (cdr form)
474 (js-format "while (")
477 (js-stmt `(progn ,@body))))
479 (destructuring-bind (value &rest cases) (cdr form)
480 (js-format "switch(")
485 ((and (consp case) (eq (car case) 'case))
487 (let ((value (cadr case)))
488 (unless (or (stringp value) (integerp value))
489 (error "Non-constant switch case `~S'." value))
493 (js-format "default:"))
498 (destructuring-bind ((start condition step) &body body) (cdr form)
506 (js-stmt `(progn ,@body))))
508 (destructuring-bind ((x object) &body body) (cdr form)
514 (js-stmt `(progn ,@body))))
516 (destructuring-bind (&rest body) (cdr form)
518 (js-stmt `(group ,@body))))
520 (destructuring-bind ((var) &rest body) (cdr form)
521 (js-format "catch (")
524 (js-stmt `(group ,@body))))
526 (destructuring-bind (&rest body) (cdr form)
527 (js-format "finally")
528 (js-stmt `(group ,@body))))
530 (destructuring-bind (object) (cdr form)
539 ;;; It is intended to be the entry point to the code generator.
540 (defun js (&rest stmts)
541 (mapc #'js-stmt stmts)