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