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