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