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