b32e837b99ba6654a945cede430bdb84aea165dd
[jscl.git] / src / compiler / codegen.lisp
1 ;;; compiler-codege.lisp --- Naive Javascript unparser
2
3 ;; copyright (C) 2013 David Vazquez
4
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.
9 ;;
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.
14 ;;
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/>.
17
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.
21 ;;;
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.
24
25 (/debug "loading compiler-codegen.lisp!")
26
27 (defvar *js-macros* nil)
28 (defmacro define-js-macro (name lambda-list &body body)
29   (let ((form (gensym)))
30     `(push (cons ',name
31                  (lambda (,form)
32                    (block ,name
33                      (destructuring-bind ,lambda-list ,form
34                        ,@body))))
35            *js-macros*)))
36
37 (defun js-macroexpand (js)
38   (if (and (consp js) (assoc (car js) *js-macros*))
39       (let ((expander (cdr (assoc (car js) *js-macros*))))
40         (multiple-value-bind (expansion stop-expand-p)
41             (funcall expander (cdr js))
42           (if stop-expand-p
43               expansion
44               (js-macroexpand expansion))))
45       js))
46
47
48 (defconstant no-comma 12)
49
50 (defvar *js-output* t)
51
52 (defvar *js-pretty-print* t)
53
54 ;;; Two seperate functions are needed for escaping strings:
55 ;;;  One for producing JavaScript string literals (which are singly or
56 ;;;   doubly quoted)
57 ;;;  And one for producing Lisp strings (which are only doubly quoted)
58 ;;;
59 ;;; The same function would suffice for both, but for javascript string
60 ;;; literals it is neater to use either depending on the context, e.g:
61 ;;;  foo's => "foo's"
62 ;;;  "foo" => '"foo"'
63 ;;; which avoids having to escape quotes where possible
64 (defun js-escape-string (string)
65   (let ((index 0)
66         (size (length string))
67         (seen-single-quote nil)
68         (seen-double-quote nil))
69     (flet ((%js-escape-string (string escape-single-quote-p)
70              (let ((output "")
71                    (index 0))
72                (while (< index size)
73                  (let ((ch (char string index)))
74                    (when (char= ch #\\)
75                      (setq output (concat output "\\")))
76                    (when (and escape-single-quote-p (char= ch #\'))
77                      (setq output (concat output "\\")))
78                    (when (char= ch #\newline)
79                      (setq output (concat output "\\"))
80                      (setq ch #\n))
81                    (setq output (concat output (string ch))))
82                  (incf index))
83                output)))
84       ;; First, scan the string for single/double quotes
85       (while (< index size)
86         (let ((ch (char string index)))
87           (when (char= ch #\')
88             (setq seen-single-quote t))
89           (when (char= ch #\")
90             (setq seen-double-quote t)))
91         (incf index))
92       ;; Then pick the appropriate way to escape the quotes
93       (cond
94         ((not seen-single-quote)
95          (concat "'"   (%js-escape-string string nil) "'"))
96         ((not seen-double-quote)
97          (concat "\""  (%js-escape-string string nil) "\""))
98         (t (concat "'" (%js-escape-string string t)   "'"))))))
99
100
101 (defun js-format (fmt &rest args)
102   (apply #'format *js-output* fmt args))
103
104 (defun valid-js-identifier (string-designator)
105   (let ((string (typecase string-designator
106                   (symbol (symbol-name string-designator))
107                   (string string-designator)
108                   (t
109                    (return-from valid-js-identifier (values nil nil))))))
110     (flet ((constitutentp (ch)
111              (or (alphanumericp ch) (member ch '(#\$ #\_)))))
112       (if (and (every #'constitutentp string)
113                (if (plusp (length string))
114                    (not (digit-char-p (char string 0)))
115                    t))
116           (values (format nil "~a" string) t)
117           (values nil nil)))))
118
119 (defun js-identifier (string-designator)
120   (multiple-value-bind (string valid)
121       (valid-js-identifier string-designator)
122     (unless valid
123       (error "~S is not a valid Javascript identifier." string))
124     (js-format "~a" string)))
125
126 (defun js-primary-expr (form)
127   (cond
128     ((numberp form)
129      (if (<= 0 form)
130          (js-format "~a" form)
131          (js-expr `(- ,(abs form)))))
132     ((stringp form)
133      (js-format "~a" (js-escape-string form)))
134     ((symbolp form)
135      (case form
136        (true      (js-format "true"))
137        (false     (js-format "false"))
138        (null      (js-format "null"))
139        (this      (js-format "this"))
140        (undefined (js-format "undefined"))
141        (otherwise
142         (js-identifier form))))
143     (t
144      (error "Unknown Javascript syntax ~S." form))))
145
146 (defun js-vector-initializer (vector)
147   (let ((size (length vector)))
148     (js-format "[")
149     (dotimes (i (1- size))
150       (let ((elt (aref vector i)))
151         (unless (eq elt 'null)
152           (js-expr elt no-comma))
153         (js-format ",")))
154     (when (plusp size)
155       (js-expr (aref vector (1- size)) no-comma))
156     (js-format "]")))
157
158 (defun js-object-initializer (plist)
159   (js-format "{")
160   (do* ((tail plist (cddr tail)))
161        ((null tail))
162     (let ((key (car tail))
163           (value (cadr tail)))
164       (multiple-value-bind (identifier identifier-p) (valid-js-identifier key)
165         (declare (ignore identifier))
166         (if identifier-p
167             (js-identifier key)
168             (js-expr (string key) no-comma)))
169       (js-format ": ")
170       (js-expr value no-comma)
171       (unless (null (cddr tail))
172         (js-format ","))))
173   (js-format "}"))
174
175 (defun js-function (arguments &rest body)
176   (js-format "function(")
177   (when arguments
178     (js-identifier (car arguments))
179     (dolist (arg (cdr arguments))
180       (js-format ",")
181       (js-identifier arg)))
182   (js-format ")")
183   (js-stmt `(group ,@body) t))
184
185 (defun check-lvalue (x)
186   (unless (or (symbolp x)
187               (nth-value 1 (valid-js-identifier x))
188               (and (consp x)
189                    (member (car x) '(get = property))))
190     (error "Bad Javascript lvalue ~S" x)))
191
192 ;;; Process the Javascript AST to reduce some syntax sugar.
193 (defun js-expand-expr (form)
194   (if (consp form)
195       (case (car form)
196         (+
197          (case (length (cdr form))
198            (1 `(unary+ ,(cadr form)))
199            (t (reduce (lambda (x y) `(+ ,x ,y)) (cdr form)))))
200         (-
201          (case (length (cdr form))
202            (1 `(unary- ,(cadr form)))
203            (t (reduce (lambda (x y) `(- ,x ,y)) (cdr form)))))
204         ((and or)
205          (reduce (lambda (x y) `(,(car form) ,x ,y)) (cdr form)))
206         ((progn comma)
207          (reduce (lambda (x y) `(comma ,x ,y)) (cdr form) :from-end t))
208         (t
209          (js-macroexpand form)))
210       form))
211
212 (defun js-operator-expression (op args precedence associativity operand-order)
213   (let ((op1 (car args))
214         (op2 (cadr args)))
215     (case op
216       ;; Accessors
217       (property
218        (js-expr (car args) 0)
219        (js-format "[")
220        (js-expr (cadr args) no-comma)
221        (js-format "]"))
222       (get
223        (multiple-value-bind (accessor accessorp)
224            (valid-js-identifier (cadr args))
225          (unless accessorp
226            (error "Invalid accessor ~S" (cadr args)))
227          (js-expr (car args) 0)
228          (js-format ".")
229          (js-identifier accessor)))
230       ;; Function call
231       (call
232        (js-expr (car args) 1)
233        (js-format "(")
234        (when (cdr args)
235          (js-expr (cadr args) no-comma)
236          (dolist (operand (cddr args))
237            (js-format ",")
238            (js-expr operand no-comma)))
239        (js-format ")"))
240       ;; Object syntax
241       (object
242        (js-object-initializer args))
243       ;; Function expressions
244       (function
245        (js-format "(")
246        (apply #'js-function args)
247        (js-format ")"))
248       (t
249        (labels ((low-precedence-p (op-precedence)
250                   (cond
251                     ((> op-precedence precedence))
252                     ((< op-precedence precedence) nil)
253                     (t (not (eq operand-order associativity)))))
254
255                 (%unary-op (operator string operator-precedence operator-associativity post lvalue)
256                   (when (eq op operator)
257                     (when lvalue (check-lvalue op1))
258                     (when (low-precedence-p operator-precedence) (js-format "("))
259                     (cond
260                       (post
261                        (js-expr op1 operator-precedence operator-associativity 'left)
262                        (js-format "~a" string))
263                       (t
264                        (js-format "~a" string)
265                        (js-expr op1 operator-precedence operator-associativity 'right)))
266                     (when (low-precedence-p operator-precedence) (js-format ")"))
267                     (return-from js-operator-expression)))
268
269                 (%binary-op (operator string operator-precedence operator-associativity lvalue)
270                   (when (eq op operator)
271                     (when lvalue (check-lvalue op1))
272                     (when (low-precedence-p operator-precedence) (js-format "("))
273                     (js-expr op1 operator-precedence operator-associativity 'left)
274                     (js-format "~a" string)
275                     (js-expr op2 operator-precedence operator-associativity 'right)
276                     (when (low-precedence-p operator-precedence) (js-format ")"))
277                     (return-from js-operator-expression))))
278
279          (macrolet ((unary-op (operator string precedence associativity &key post lvalue)
280                       `(%unary-op ',operator ',string ',precedence ',associativity ',post ',lvalue))
281                     (binary-op (operator string precedence associativity &key lvalue)
282                       `(%binary-op ',operator ',string ',precedence ',associativity ',lvalue)))
283
284            (unary-op pre++       "++"            2    right :lvalue t)
285            (unary-op pre--       "--"            2    right :lvalue t)
286            (unary-op post++      "++"            2    right :lvalue t :post t)
287            (unary-op post--      "--"            2    right :lvalue t :post t)
288            (unary-op not         "!"             2    right)
289            (unary-op bit-not     "~"             2    right)
290            ;; Note that the leading space is necessary because it
291            ;; could break with post++, for example. TODO: Avoid
292            ;; leading space when it's possible.
293            (unary-op unary+      " +"            2    right)
294            (unary-op unary-      " -"            2    right)
295            (unary-op delete      "delete "       2    right)
296            (unary-op void        "void "         2    right)
297            (unary-op typeof      "typeof "       2    right)
298            (unary-op new         "new "          2    right)
299
300            (binary-op *          "*"             3    left)
301            (binary-op /          "/"             3    left)
302            (binary-op mod        "%"             3    left)
303            (binary-op %          "%"             3    left)
304            (binary-op +          "+"             4    left)
305            (binary-op -          "-"             5    left)
306            (binary-op <<         "<<"            5    left)
307            (binary-op >>         "<<"            5    left)
308            (binary-op >>>        ">>>"           5    left)
309            (binary-op <=         "<="            6    left)
310            (binary-op <          "<"             6    left)
311            (binary-op >          ">"             6    left)
312            (binary-op >=         ">="            6    left)
313            (binary-op instanceof " instanceof "  6    left)
314            (binary-op in         " in "          6    left)
315            (binary-op ==         "=="            7    left)
316            (binary-op !=         "!="            7    left)
317            (binary-op ===        "==="           7    left)
318            (binary-op !==        "!=="           7    left)
319            (binary-op bit-and    "&"             8    left)
320            (binary-op bit-xor    "^"             9    left)
321            (binary-op bit-or     "|"            10    left)
322            (binary-op and        "&&"           11    left)
323            (binary-op or         "||"           12    left)
324            (binary-op =          "="            13    right :lvalue t)
325            (binary-op +=         "+="           13    right :lvalue t)
326            (binary-op incf       "+="           13    right :lvalue t)
327            (binary-op -=         "-="           13    right :lvalue t)
328            (binary-op decf       "-="           13    right :lvalue t)
329            (binary-op *=         "*="           13    right :lvalue t)
330            (binary-op /=         "*="           13    right :lvalue t)
331            (binary-op bit-xor=   "^="           13    right :lvalue t)
332            (binary-op bit-and=   "&="           13    right :lvalue t)
333            (binary-op bit-or=    "|="           13    right :lvalue t)
334            (binary-op <<=        "<<="          13    right :lvalue t)
335            (binary-op >>=        ">>="          13    right :lvalue t)
336            (binary-op >>>=       ">>>="         13    right :lvalue t)
337
338            (binary-op comma      ","            13    right)
339            (binary-op progn      ","            13    right)
340
341            (when (member op '(? if))
342              (when (low-precedence-p 12) (js-format "("))
343              (js-expr (first args) 12 'right 'left)
344              (js-format "?")
345              (js-expr (second args) 12 'right 'right)
346              (js-format ":")
347              (js-expr (third args) 12 'right 'right)
348              (when (low-precedence-p 12) (js-format ")"))
349              (return-from js-operator-expression))
350
351            (error "Unknown operator `~S'" op)))))))
352
353 (defun js-expr (form &optional (precedence 1000) associativity operand-order)
354   (let ((form (js-expand-expr form)))
355     (cond
356       ((or (symbolp form) (numberp form) (stringp form))
357        (js-primary-expr form))
358       ((vectorp form)
359        (js-vector-initializer form))
360       (t
361        (js-operator-expression (car form) (cdr form) precedence associativity operand-order)))))
362
363 (defun js-expand-stmt (form)
364   (cond
365     ((and (consp form) (eq (car form) 'progn))
366      (destructuring-bind (&body body) (cdr form)
367        (cond
368          ((null body)
369           nil)
370          ((null (cdr body))
371           (js-expand-stmt (car body)))
372          (t
373           `(group ,@(cdr form))))))
374     (t
375      (js-macroexpand form))))
376
377 (defun js-end-stmt ()
378   (js-format ";")
379   (when *js-pretty-print*
380     (js-format "~%")))
381
382 (defun js-stmt (form &optional parent)
383   (let ((form (js-expand-stmt form)))
384     (flet ((js-stmt (x) (js-stmt x form)))
385       (cond
386         ((null form)
387          (unless (or (and (consp parent) (eq (car parent) 'group))
388                      (null parent))
389            (js-end-stmt)))
390         ((atom form)
391          (progn
392            (js-expr form)
393            (js-end-stmt)))
394         (t
395          (case (car form)
396            (label
397             (destructuring-bind (label &body body) (cdr form)
398               (js-identifier label)
399               (js-format ":")
400               (js-stmt `(progn ,@body))))
401            (break
402             (destructuring-bind (&optional label) (cdr form)
403               (js-format "break")
404               (when label
405                 (js-format " ")
406                 (js-identifier label))
407               (js-end-stmt)))
408            (return
409              (destructuring-bind (value) (cdr form)
410                (js-format "return ")
411                (js-expr value)
412                (js-end-stmt)))
413            (var
414             (flet ((js-var (spec)
415                      (destructuring-bind (variable &optional initial)
416                          (ensure-list spec)
417                        (js-identifier variable)
418                        (when initial
419                          (js-format "=")
420                          (js-expr initial no-comma)))))
421               (destructuring-bind (var &rest vars) (cdr form)
422                 (js-format "var ")
423                 (js-var var)
424                 (dolist (var vars)
425                   (js-format ",")
426                   (js-var var))
427                 (js-end-stmt))))
428            (if
429             (destructuring-bind (condition true &optional false) (cdr form)
430               (js-format "if (")
431               (js-expr condition)
432               (js-format ") ")
433               (js-stmt true)
434               (when false
435                 (js-format " else ")
436                 (js-stmt false))))
437            (group
438             (let ((in-group-p
439                    (or (null parent)
440                        (and (consp parent) (eq (car parent) 'group)))))
441               (unless  in-group-p (js-format "{"))
442               (mapc #'js-stmt (cdr form))
443               (unless in-group-p (js-format "}"))))
444            (while
445                (destructuring-bind (condition &body body) (cdr form)
446                  (js-format "while (")
447                  (js-expr condition)
448                  (js-format ")")
449                  (js-stmt `(progn ,@body))))
450            (switch
451             (destructuring-bind (value &rest cases) (cdr form)
452               (js-format "switch(")
453               (js-expr value)
454               (js-format "){")
455               (dolist (case cases)
456                 (cond
457                   ((and (consp case) (eq (car case) 'case))
458                    (js-format "case ")
459                    (let ((value (cadr case)))
460                      (unless (or (stringp value) (integerp value))
461                        (error "Non-constant switch case `~S'." value))
462                      (js-expr value))
463                    (js-format ":"))
464                   ((eq case 'default)
465                    (js-format "default:"))
466                   (t
467                    (js-stmt case))))
468               (js-format "}")))
469            (for
470             (destructuring-bind ((start condition step) &body body) (cdr form)
471               (js-format "for (")
472               (js-expr start)
473               (js-format ";")
474               (js-expr condition)
475               (js-format ";")
476               (js-expr step)
477               (js-format ")")
478               (js-stmt `(progn ,@body))))
479            (for-in
480             (destructuring-bind ((x object) &body body) (cdr form)
481               (js-format "for (")
482               (js-identifier x)
483               (js-format " in ")
484               (js-expr object)
485               (js-format ")")
486               (js-stmt `(progn ,@body))))
487            (try
488             (destructuring-bind (&rest body) (cdr form)
489               (js-format "try")
490               (js-stmt `(group ,@body))))
491            (catch
492                (destructuring-bind ((var) &rest body) (cdr form)
493                  (js-format "catch (")
494                  (js-identifier var)
495                  (js-format ")")
496                  (js-stmt `(group ,@body))))
497            (finally
498             (destructuring-bind (&rest body) (cdr form)
499               (js-format "finally")
500               (js-stmt `(group ,@body))))
501            (throw
502                (destructuring-bind (object) (cdr form)
503                  (js-format "throw ")
504                  (js-expr object)
505                  (js-end-stmt)))
506            (t
507             (js-expr form)
508             (js-end-stmt))))))))
509
510 (defun js (&rest stmts)
511   (mapc #'js-stmt stmts)
512   nil)