experimental/codegen.lisp

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