src/compiler/codegen.lisp

   1 ;;; compiler-codege.lisp --- Naive Javascript unparser
   2
   3 ;; Copyright (C) 2013, 2014 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
  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.
  22 ;;;
  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.
  25
  26 (/debug "loading compiler-codegen.lisp!")
  27
  28
  29 (defvar *js-macros* nil)
  30 (defmacro define-js-macro (name lambda-list &body body)
  31   (let ((form (gensym)))
  32     `(push (cons ',name
  33                  (lambda (,form)
  34                    (block ,name
  35                      (destructuring-bind ,lambda-list ,form
  36                        ,@body))))
  37            *js-macros*)))
  38
  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))
  44           (if stop-expand-p
  45               expansion
  46               (js-macroexpand expansion))))
  47       js))
  48
  49
  50 (defconstant no-comma 12)
  51
  52 (defvar *js-output* t)
  53
  54 (defvar *js-pretty-print* t)
  55
  56 ;;; Two seperate functions are needed for escaping strings:
  57 ;;;  One for producing JavaScript string literals (which are singly or
  58 ;;;   doubly quoted)
  59 ;;;  And one for producing Lisp strings (which are only doubly quoted)
  60 ;;;
  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:
  63 ;;;  foo's => "foo's"
  64 ;;;  "foo" => '"foo"'
  65 ;;; which avoids having to escape quotes where possible
  66 (defun js-escape-string (string)
  67   (let ((index 0)
  68         (size (length string))
  69         (seen-single-quote nil)
  70         (seen-double-quote nil))
  71     (flet ((%js-escape-string (string escape-single-quote-p)
  72              (let ((output "")
  73                    (index 0))
  74                (while (< index size)
  75                  (let ((ch (char string index)))
  76                    (when (char= ch #\\)
  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 "\\"))
  82                      (setq ch #\n))
  83                    (setq output (concat output (string ch))))
  84                  (incf index))
  85                output)))
  86       ;; First, scan the string for single/double quotes
  87       (while (< index size)
  88         (let ((ch (char string index)))
  89           (when (char= ch #\')
  90             (setq seen-single-quote t))
  91           (when (char= ch #\")
  92             (setq seen-double-quote t)))
  93         (incf index))
  94       ;; Then pick the appropriate way to escape the quotes
  95       (cond
  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)   "'"))))))
 101
 102
 103 (defun js-format (fmt &rest args)
 104   (apply #'format *js-output* fmt args))
 105
 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)
 113                   (t
 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)))
 120                    t))
 121           (values string t)
 122           (values nil nil)))))
 123
 124
 125 ;;; Expression generators
 126 ;;;
 127 ;;; `js-expr' and the following auxiliary functions are the
 128 ;;; responsible for generating Javascript expression.
 129
 130 (defun js-identifier (string-designator)
 131   (multiple-value-bind (string valid)
 132       (valid-js-identifier string-designator)
 133     (unless valid
 134       (error "~S is not a valid Javascript identifier." string))
 135     (js-format "~a" string)))
 136
 137 (defun js-primary-expr (form)
 138   (cond
 139     ((numberp form)
 140      (if (<= 0 form)
 141          (js-format "~a" form)
 142          (js-expr `(- ,(abs form)))))
 143     ((stringp form)
 144      (js-format "~a" (js-escape-string form)))
 145     ((symbolp form)
 146      (case 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"))
 152        (otherwise
 153         (js-identifier form))))
 154     (t
 155      (error "Unknown Javascript syntax ~S." form))))
 156
 157 (defun js-vector-initializer (vector)
 158   (let ((size (length vector)))
 159     (js-format "[")
 160     (dotimes (i (1- size))
 161       (let ((elt (aref vector i)))
 162         (unless (eq elt 'null)
 163           (js-expr elt no-comma))
 164         (js-format ",")))
 165     (when (plusp size)
 166       (js-expr (aref vector (1- size)) no-comma))
 167     (js-format "]")))
 168
 169 (defun js-object-initializer (plist)
 170   (js-format "{")
 171   (do* ((tail plist (cddr tail)))
 172        ((null tail))
 173     (let ((key (car tail))
 174           (value (cadr tail)))
 175       (multiple-value-bind (identifier identifier-p) (valid-js-identifier key)
 176         (declare (ignore identifier))
 177         (if identifier-p
 178             (js-identifier key)
 179             (js-expr (string key) no-comma)))
 180       (js-format ": ")
 181       (js-expr value no-comma)
 182       (unless (null (cddr tail))
 183         (js-format ","))))
 184   (js-format "}"))
 185
 186 (defun js-function (arguments &rest body)
 187   (js-format "function(")
 188   (when arguments
 189     (js-identifier (car arguments))
 190     (dolist (arg (cdr arguments))
 191       (js-format ",")
 192       (js-identifier arg)))
 193   (js-format ")")
 194   (js-stmt `(group ,@body) t))
 195
 196 (defun check-lvalue (x)
 197   (unless (or (symbolp x)
 198               (nth-value 1 (valid-js-identifier x))
 199               (and (consp x)
 200                    (member (car x) '(get = property))))
 201     (error "Bad Javascript lvalue ~S" x)))
 202
 203 ;;; Process the Javascript AST to reduce some syntax sugar.
 204 (defun js-expand-expr (form)
 205   (if (consp form)
 206       (case (car form)
 207         (+
 208          (case (length (cdr form))
 209            (1 `(unary+ ,(cadr form)))
 210            (t (reduce (lambda (x y) `(+ ,x ,y)) (cdr form)))))
 211         (-
 212          (case (length (cdr form))
 213            (1 `(unary- ,(cadr form)))
 214            (t (reduce (lambda (x y) `(- ,x ,y)) (cdr form)))))
 215         (*
 216          (case (length (cdr form))
 217            (0 1)
 218            (t (reduce (lambda (x y) `(* ,x ,y)) (cdr form)))))
 219         ((and or)
 220          (reduce (lambda (x y) `(,(car form) ,x ,y)) (cdr form)))
 221         ((progn comma)
 222          (reduce (lambda (x y) `(comma ,x ,y)) (cdr form) :from-end t))
 223         (t
 224          (js-macroexpand form)))
 225       form))
 226
 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))
 233         (op2 (cadr args)))
 234     (case op
 235       ;; Accessors
 236       (property
 237        (js-expr (car args) 0)
 238        (js-format "[")
 239        (js-expr (cadr args) no-comma)
 240        (js-format "]"))
 241       (get
 242        (multiple-value-bind (accessor accessorp)
 243            (valid-js-identifier (cadr args))
 244          (unless accessorp
 245            (error "Invalid accessor ~S" (cadr args)))
 246          (js-expr (car args) 0)
 247          (js-format ".")
 248          (js-identifier accessor)))
 249       ;; Function call
 250       (call
 251        (js-expr (car args) 1)
 252        (js-format "(")
 253        (when (cdr args)
 254          (js-expr (cadr args) no-comma)
 255          (dolist (operand (cddr args))
 256            (js-format ",")
 257            (js-expr operand no-comma)))
 258        (js-format ")"))
 259       ;; Object syntax
 260       (object
 261        (js-object-initializer args))
 262       ;; Function expressions
 263       (function
 264        (js-format "(")
 265        (apply #'js-function args)
 266        (js-format ")"))
 267       (t
 268        (labels ((low-precedence-p (op-precedence)
 269                   (cond
 270                     ((> op-precedence precedence))
 271                     ((< op-precedence precedence) nil)
 272                     (t (not (eq operand-order associativity)))))
 273
 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 "("))
 278                     (cond
 279                       (post
 280                        (js-expr op1 operator-precedence operator-associativity 'left)
 281                        (js-format "~a" string))
 282                       (t
 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)))
 287
 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))))
 297
 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)))
 302
 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)
 318
 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)
 356
 357            (binary-op comma      ","            13    right)
 358            (binary-op progn      ","            13    right)
 359
 360            (when (member op '(? if))
 361              (when (low-precedence-p 12) (js-format "("))
 362              (js-expr (first args) 12 'right 'left)
 363              (js-format "?")
 364              (js-expr (second args) 12 'right 'right)
 365              (js-format ":")
 366              (js-expr (third args) 12 'right 'right)
 367              (when (low-precedence-p 12) (js-format ")"))
 368              (return-from js-operator-expression))
 369
 370            (error "Unknown operator `~S'" op)))))))
 371
 372 (defun js-expr (form &optional (precedence 1000) associativity operand-order)
 373   (let ((form (js-expand-expr form)))
 374     (cond
 375       ((or (symbolp form) (numberp form) (stringp form))
 376        (js-primary-expr form))
 377       ((vectorp form)
 378        (js-vector-initializer form))
 379       (t
 380        (js-operator-expression (car form) (cdr form) precedence associativity operand-order)))))
 381
 382
 383
 384 ;;; Statements generators
 385 ;;;
 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).
 389 ;;;
 390
 391 (defun js-expand-stmt (form)
 392   (cond
 393     ((and (consp form) (eq (car form) 'progn))
 394      (destructuring-bind (&body body) (cdr form)
 395        (cond
 396          ((null body)
 397           nil)
 398          ((null (cdr body))
 399           (js-expand-stmt (car body)))
 400          (t
 401           `(group ,@(cdr form))))))
 402     (t
 403      (js-macroexpand form))))
 404
 405 (defun js-end-stmt ()
 406   (js-format ";")
 407   (when *js-pretty-print*
 408     (js-format "~%")))
 409
 410 (defun js-stmt (form &optional parent)
 411   (let ((form (js-expand-stmt form)))
 412     (flet ((js-stmt (x) (js-stmt x form)))
 413       (cond
 414         ((null form)
 415          (unless (or (and (consp parent) (eq (car parent) 'group))
 416                      (null parent))
 417            (js-end-stmt)))
 418         ((atom form)
 419          (progn
 420            (js-expr form)
 421            (js-end-stmt)))
 422         (t
 423          (case (car form)
 424            (label
 425             (destructuring-bind (label &body body) (cdr form)
 426               (js-identifier label)
 427               (js-format ":")
 428               (js-stmt `(progn ,@body))))
 429            (break
 430             (destructuring-bind (&optional label) (cdr form)
 431               (js-format "break")
 432               (when label
 433                 (js-format " ")
 434                 (js-identifier label))
 435               (js-end-stmt)))
 436            (return
 437              (destructuring-bind (value) (cdr form)
 438                (js-format "return ")
 439                (js-expr value)
 440                (js-end-stmt)))
 441            (var
 442             (flet ((js-var (spec)
 443                      (destructuring-bind (variable &optional initial)
 444                          (ensure-list spec)
 445                        (js-identifier variable)
 446                        (when initial
 447                          (js-format "=")
 448                          (js-expr initial no-comma)))))
 449               (destructuring-bind (var &rest vars) (cdr form)
 450                 (js-format "var ")
 451                 (js-var var)
 452                 (dolist (var vars)
 453                   (js-format ",")
 454                   (js-var var))
 455                 (js-end-stmt))))
 456            (if
 457             (destructuring-bind (condition true &optional false) (cdr form)
 458               (js-format "if (")
 459               (js-expr condition)
 460               (js-format ") ")
 461               (js-stmt true)
 462               (when false
 463                 (js-format " else ")
 464                 (js-stmt false))))
 465            (group
 466             (let ((in-group-p
 467                    (or (null parent)
 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 "}"))))
 472            (while
 473                (destructuring-bind (condition &body body) (cdr form)
 474                  (js-format "while (")
 475                  (js-expr condition)
 476                  (js-format ")")
 477                  (js-stmt `(progn ,@body))))
 478            (switch
 479             (destructuring-bind (value &rest cases) (cdr form)
 480               (js-format "switch(")
 481               (js-expr value)
 482               (js-format "){")
 483               (dolist (case cases)
 484                 (cond
 485                   ((and (consp case) (eq (car case) 'case))
 486                    (js-format "case ")
 487                    (let ((value (cadr case)))
 488                      (unless (or (stringp value) (integerp value))
 489                        (error "Non-constant switch case `~S'." value))
 490                      (js-expr value))
 491                    (js-format ":"))
 492                   ((eq case 'default)
 493                    (js-format "default:"))
 494                   (t
 495                    (js-stmt case))))
 496               (js-format "}")))
 497            (for
 498             (destructuring-bind ((start condition step) &body body) (cdr form)
 499               (js-format "for (")
 500               (js-expr start)
 501               (js-format ";")
 502               (js-expr condition)
 503               (js-format ";")
 504               (js-expr step)
 505               (js-format ")")
 506               (js-stmt `(progn ,@body))))
 507            (for-in
 508             (destructuring-bind ((x object) &body body) (cdr form)
 509               (js-format "for (")
 510               (js-identifier x)
 511               (js-format " in ")
 512               (js-expr object)
 513               (js-format ")")
 514               (js-stmt `(progn ,@body))))
 515            (try
 516             (destructuring-bind (&rest body) (cdr form)
 517               (js-format "try")
 518               (js-stmt `(group ,@body))))
 519            (catch
 520                (destructuring-bind ((var) &rest body) (cdr form)
 521                  (js-format "catch (")
 522                  (js-identifier var)
 523                  (js-format ")")
 524                  (js-stmt `(group ,@body))))
 525            (finally
 526             (destructuring-bind (&rest body) (cdr form)
 527               (js-format "finally")
 528               (js-stmt `(group ,@body))))
 529            (throw
 530                (destructuring-bind (object) (cdr form)
 531                  (js-format "throw ")
 532                  (js-expr object)
 533                  (js-end-stmt)))
 534            (t
 535             (js-expr form)
 536             (js-end-stmt))))))))
 537
 538
 539 ;;; It is intended to be the entry point to the code generator.
 540 (defun js (&rest stmts)
 541   (mapc #'js-stmt stmts)
 542   nil)