| 1 | (in-package "PARENSCRIPT") |
| 2 | |
| 3 | (defvar *ps-print-pretty* t) |
| 4 | (defvar *indent-num-spaces* 4) |
| 5 | (defvar *js-string-delimiter* #\' |
| 6 | "Specifies which character should be used for delimiting strings. |
| 7 | |
| 8 | This variable is used when you want to embed the resulting JavaScript |
| 9 | in an html attribute delimited by #\\\" as opposed to #\\', or |
| 10 | vice-versa.") |
| 11 | |
| 12 | (defvar *indent-level*) |
| 13 | |
| 14 | (defvar *psw-stream*) |
| 15 | |
| 16 | (defun parenscript-print (form immediate?) |
| 17 | (declare (special immediate?)) |
| 18 | (let ((*indent-level* 0) |
| 19 | (*psw-stream* (if immediate? |
| 20 | *psw-stream* |
| 21 | (make-string-output-stream))) |
| 22 | (%psw-accumulator ())) |
| 23 | (declare (special %psw-accumulator)) |
| 24 | (if (and (listp form) (eq 'js:block (car form))) ; ignore top-level block |
| 25 | (loop for (statement . remaining) on (cdr form) do |
| 26 | (ps-print statement) (psw #\;) (when remaining (psw #\Newline))) |
| 27 | (ps-print form)) |
| 28 | (unless immediate? |
| 29 | (reverse (cons (get-output-stream-string *psw-stream*) %psw-accumulator))))) |
| 30 | |
| 31 | (defun psw (obj) |
| 32 | (declare (special %psw-accumulator immediate?)) |
| 33 | (typecase obj |
| 34 | (string (write-string obj *psw-stream*)) |
| 35 | (character (write-char obj *psw-stream*)) |
| 36 | (otherwise |
| 37 | (if immediate? |
| 38 | (write-string (eval obj) *psw-stream*) |
| 39 | (setf %psw-accumulator |
| 40 | (cons obj |
| 41 | (cons (get-output-stream-string *psw-stream*) |
| 42 | %psw-accumulator))))))) |
| 43 | |
| 44 | (defgeneric ps-print% (special-form-name special-form-args)) |
| 45 | |
| 46 | (defmacro defprinter (special-form content-args &body body) |
| 47 | "Given a special-form name and a destructuring lambda-list for its |
| 48 | arguments, defines a printer for that form using the given body." |
| 49 | (let ((sf (gensym)) |
| 50 | (sf-args (gensym))) |
| 51 | `(defmethod ps-print% ((,sf (eql ',special-form)) ,sf-args) |
| 52 | (declare (ignorable ,sf)) |
| 53 | (destructuring-bind ,content-args |
| 54 | ,sf-args |
| 55 | ,@body)))) |
| 56 | |
| 57 | (defgeneric ps-print (compiled-form)) |
| 58 | |
| 59 | (defmethod ps-print ((form null))) ; don't print top-level nils (ex: result of defining macros, etc.) |
| 60 | |
| 61 | (defmethod ps-print ((s symbol)) |
| 62 | (assert (keywordp s) nil "~S is not a symbol" s) |
| 63 | (ps-print (string-downcase s))) |
| 64 | |
| 65 | (defmethod ps-print ((compiled-form cons)) |
| 66 | (ps-print% (car compiled-form) (cdr compiled-form))) |
| 67 | |
| 68 | (defun newline-and-indent () |
| 69 | (if *ps-print-pretty* |
| 70 | (progn (psw #\Newline) |
| 71 | (loop repeat (* *indent-level* *indent-num-spaces*) do (psw #\Space))) |
| 72 | (psw #\Space))) |
| 73 | |
| 74 | (defparameter *js-lisp-escaped-chars* |
| 75 | '((#\' . #\') |
| 76 | (#\\ . #\\) |
| 77 | (#\b . #\Backspace) |
| 78 | (#\f . #.(code-char 12)) |
| 79 | (#\n . #\Newline) |
| 80 | (#\r . #\Return) |
| 81 | (#\t . #\Tab))) |
| 82 | |
| 83 | (defmethod ps-print ((string string)) |
| 84 | (flet ((lisp-special-char-to-js (lisp-char) |
| 85 | (car (rassoc lisp-char *js-lisp-escaped-chars*)))) |
| 86 | (psw *js-string-delimiter*) |
| 87 | (loop for char across string |
| 88 | for code = (char-code char) |
| 89 | for special = (lisp-special-char-to-js char) |
| 90 | do (cond (special (psw #\\) (psw special)) |
| 91 | ((or (<= code #x1f) (>= code #x80)) (format *psw-stream* "\\u~4,'0x" code)) |
| 92 | (t (psw char)))) |
| 93 | (psw *js-string-delimiter*))) |
| 94 | |
| 95 | (defmethod ps-print ((number number)) |
| 96 | (format *psw-stream* (if (integerp number) "~S" "~F") number)) |
| 97 | |
| 98 | ;;; expression and operator precedence rules |
| 99 | |
| 100 | (defun expression-precedence (expr) |
| 101 | (if (consp expr) |
| 102 | (case (car expr) |
| 103 | ((js:slot-value js:aref) (op-precedence (car expr))) |
| 104 | (js:= (op-precedence 'js:=)) |
| 105 | (js:? (op-precedence 'js:?)) |
| 106 | (js:unary-operator (op-precedence (second expr))) |
| 107 | (operator (op-precedence (second expr))) |
| 108 | (otherwise -1)) |
| 109 | -1)) |
| 110 | |
| 111 | (defprinter js:literal (str) |
| 112 | (psw str)) |
| 113 | |
| 114 | (defun print-comma-delimited-list (ps-forms) |
| 115 | (loop for (form . remaining) on ps-forms do |
| 116 | (ps-print form) (when remaining (psw ", ")))) |
| 117 | |
| 118 | (defprinter js:array (&rest initial-contents) |
| 119 | (psw #\[) (print-comma-delimited-list initial-contents) (psw #\])) |
| 120 | |
| 121 | (defprinter js:aref (array indices) |
| 122 | (if (>= (expression-precedence array) (op-precedence 'js:aref)) |
| 123 | (parenthesize-print array) |
| 124 | (ps-print array)) |
| 125 | (loop for idx in indices do |
| 126 | (psw #\[) (ps-print idx) (psw #\]))) |
| 127 | |
| 128 | (defvar *lexical-bindings* nil) |
| 129 | |
| 130 | (defun rename-js-variable (name) |
| 131 | (or (cdr (assoc name *lexical-bindings*)) |
| 132 | name)) |
| 133 | |
| 134 | (defprinter js:let (variables &body body) |
| 135 | (let ((*lexical-bindings* |
| 136 | (append (mapcar (lambda (var) |
| 137 | (cons var (if (assoc var *lexical-bindings*) |
| 138 | (ps-gensym var) |
| 139 | var))) |
| 140 | variables)))) |
| 141 | (loop for (exp . remaining) on body do |
| 142 | (ps-print exp) (when remaining (psw ";") (newline-and-indent))))) |
| 143 | |
| 144 | (defprinter js:variable (var) |
| 145 | (psw (symbol-to-js-string (rename-js-variable var)))) |
| 146 | |
| 147 | ;;; arithmetic operators |
| 148 | (defun parenthesize-print (ps-form) |
| 149 | (psw #\() (ps-print ps-form) (psw #\))) |
| 150 | |
| 151 | (defprinter js:operator (op &rest args) |
| 152 | (loop for (arg . remaining) on args |
| 153 | with precedence = (op-precedence op) do |
| 154 | (if (>= (expression-precedence arg) precedence) |
| 155 | (parenthesize-print arg) |
| 156 | (ps-print arg)) |
| 157 | (when remaining (format *psw-stream* " ~(~A~) " op)))) |
| 158 | |
| 159 | (defprinter js:unary-operator (op arg &key prefix space) |
| 160 | (when prefix (format *psw-stream* "~(~a~)~:[~; ~]" op space)) |
| 161 | (if (> (expression-precedence arg) |
| 162 | (op-precedence (case op |
| 163 | (+ 'unary+) |
| 164 | (- 'unary-) |
| 165 | (t op)))) |
| 166 | (parenthesize-print arg) |
| 167 | (ps-print arg)) |
| 168 | (unless prefix (format *psw-stream* "~(~a~)" op))) |
| 169 | |
| 170 | (defprinter js::funcall (fun-designator &rest args) |
| 171 | (funcall (if (member (car fun-designator) '(js:variable js:aref js:slot-value js::funcall)) |
| 172 | #'ps-print |
| 173 | #'parenthesize-print) |
| 174 | fun-designator) |
| 175 | (psw #\() (print-comma-delimited-list args) (psw #\))) |
| 176 | |
| 177 | (defprinter js:|,| (&rest expressions) |
| 178 | (psw #\() |
| 179 | (loop for (exp . remaining) on expressions do |
| 180 | (ps-print exp) (when remaining (psw ", "))) |
| 181 | (psw #\))) |
| 182 | |
| 183 | (defprinter js:block (&rest statements) |
| 184 | (psw #\{) |
| 185 | (incf *indent-level*) |
| 186 | (dolist (statement statements) |
| 187 | (newline-and-indent) (ps-print statement) (psw #\;)) |
| 188 | (decf *indent-level*) |
| 189 | (newline-and-indent) |
| 190 | (psw #\})) |
| 191 | |
| 192 | (defprinter js:lambda (args body) |
| 193 | (print-fun-def nil args body)) |
| 194 | |
| 195 | (defprinter js:defun (name args body) |
| 196 | (print-fun-def name args body)) |
| 197 | |
| 198 | (defun print-fun-def (name args body-block) |
| 199 | (format *psw-stream* "function ~:[~;~A~](" name (symbol-to-js-string name)) |
| 200 | (loop for (arg . remaining) on args do |
| 201 | (psw (symbol-to-js-string arg)) (when remaining (psw ", "))) |
| 202 | (psw ") ") |
| 203 | (ps-print body-block)) |
| 204 | |
| 205 | (defprinter js:object (&rest slot-defs) |
| 206 | (psw "{ ") |
| 207 | (loop for ((slot-name . slot-value) . remaining) on slot-defs do |
| 208 | (ps-print slot-name) (psw " : ") (ps-print slot-value) |
| 209 | (when remaining (psw ", "))) |
| 210 | (psw " }")) |
| 211 | |
| 212 | (defprinter js:slot-value (obj slot) |
| 213 | (if (or (> (expression-precedence obj) (op-precedence 'js:slot-value)) |
| 214 | (numberp obj) |
| 215 | (and (listp obj) (member (car obj) '(js:lambda js:object)))) |
| 216 | (parenthesize-print obj) |
| 217 | (ps-print obj)) |
| 218 | (if (and (symbolp slot) (not (keywordp slot))) |
| 219 | (progn (psw #\.) (psw (symbol-to-js-string slot))) |
| 220 | (progn (psw #\[) (ps-print slot) (psw #\])))) |
| 221 | |
| 222 | (defprinter js:if (test consequent &rest clauses) |
| 223 | (psw "if (") (ps-print test) (psw ") ") |
| 224 | (ps-print consequent) |
| 225 | (loop while clauses do |
| 226 | (ecase (car clauses) |
| 227 | (:else-if (psw " else if (") (ps-print (cadr clauses)) (psw ") ") |
| 228 | (ps-print (caddr clauses)) |
| 229 | (setf clauses (cdddr clauses))) |
| 230 | (:else (psw " else ") |
| 231 | (ps-print (cadr clauses)) |
| 232 | (return))))) |
| 233 | |
| 234 | (defprinter js:? (test then else) |
| 235 | (if (>= (expression-precedence test) (op-precedence 'js:?)) |
| 236 | (parenthesize-print test) |
| 237 | (ps-print test)) |
| 238 | (psw " ? ") |
| 239 | (if (>= (expression-precedence then) (op-precedence 'js:?)) |
| 240 | (parenthesize-print then) |
| 241 | (ps-print then)) |
| 242 | (psw " : ") |
| 243 | (if (>= (expression-precedence else) (op-precedence 'js:?)) |
| 244 | (parenthesize-print else) |
| 245 | (ps-print else))) |
| 246 | |
| 247 | (defprinter js:= (lhs rhs) |
| 248 | (ps-print lhs) (psw " = ") (ps-print rhs)) |
| 249 | |
| 250 | (defprinter js:var (var-name &rest var-value) |
| 251 | (psw "var ") |
| 252 | (ps-print var-name) |
| 253 | (when var-value |
| 254 | (psw " = ") |
| 255 | (ps-print (car var-value)))) |
| 256 | |
| 257 | (defprinter js:break (&optional label) |
| 258 | (psw "break") |
| 259 | (when label |
| 260 | (psw " ") |
| 261 | (psw (symbol-to-js-string label)))) |
| 262 | |
| 263 | (defprinter js:continue (&optional label) |
| 264 | (psw "continue") |
| 265 | (when label |
| 266 | (psw " ") |
| 267 | (psw (symbol-to-js-string label)))) |
| 268 | |
| 269 | ;;; iteration |
| 270 | (defprinter js:for (label vars tests steps body-block) |
| 271 | (when label (psw (symbol-to-js-string label)) (psw ": ") (newline-and-indent)) |
| 272 | (psw "for (") |
| 273 | (loop for ((var-name . var-init) . remaining) on vars |
| 274 | for decl = "var " then "" do |
| 275 | (psw decl) (psw (symbol-to-js-string var-name)) (psw " = ") (ps-print var-init) (when remaining (psw ", "))) |
| 276 | (psw "; ") |
| 277 | (loop for (test . remaining) on tests do |
| 278 | (ps-print test) (when remaining (psw ", "))) |
| 279 | (psw "; ") |
| 280 | (loop for (step . remaining) on steps do |
| 281 | (ps-print step) (when remaining (psw ", "))) |
| 282 | (psw ") ") |
| 283 | (ps-print body-block)) |
| 284 | |
| 285 | (defprinter js:for-in (var object body-block) |
| 286 | (psw "for (var ") (ps-print var) (psw " in ") |
| 287 | (if (> (expression-precedence object) (op-precedence 'in)) |
| 288 | (parenthesize-print object) |
| 289 | (ps-print object)) |
| 290 | (psw ") ") |
| 291 | (ps-print body-block)) |
| 292 | |
| 293 | (defprinter js:while (test body-block) |
| 294 | (psw "while (") (ps-print test) (psw ") ") |
| 295 | (ps-print body-block)) |
| 296 | |
| 297 | (defprinter js:with (expression body-block) |
| 298 | (psw "with (") (ps-print expression) (psw ") ") |
| 299 | (ps-print body-block)) |
| 300 | |
| 301 | (defprinter js:switch (test clauses) |
| 302 | (flet ((print-body-statements (body-statements) |
| 303 | (incf *indent-level*) |
| 304 | (loop for statement in body-statements do |
| 305 | (progn (newline-and-indent) |
| 306 | (ps-print statement) |
| 307 | (psw #\;))) |
| 308 | (decf *indent-level*))) |
| 309 | (psw "switch (") (ps-print test) (psw ") {") |
| 310 | (loop for (val . statements) in clauses |
| 311 | do (progn (newline-and-indent) |
| 312 | (if (eq val 'default) |
| 313 | (progn (psw "default: ") |
| 314 | (print-body-statements statements)) |
| 315 | (progn (psw "case ") |
| 316 | (ps-print val) |
| 317 | (psw #\:) |
| 318 | (print-body-statements statements))))) |
| 319 | (newline-and-indent) |
| 320 | (psw #\}))) |
| 321 | |
| 322 | (defprinter js:try (body-block &key catch finally) |
| 323 | (psw "try ") |
| 324 | (ps-print body-block) |
| 325 | (when catch |
| 326 | (psw " catch (") (psw (symbol-to-js-string (first catch))) (psw ") ") |
| 327 | (ps-print (second catch))) |
| 328 | (when finally |
| 329 | (psw " finally ") |
| 330 | (ps-print finally))) |
| 331 | |
| 332 | ;;; regex |
| 333 | (defprinter js:regex (regex) |
| 334 | (let ((slash (unless (and (> (length regex) 0) (char= (char regex 0) #\/)) "/"))) |
| 335 | (psw (concatenate 'string slash regex slash)))) |
| 336 | |
| 337 | ;;; conditional compilation |
| 338 | (defprinter js:cc-if (test &rest body) |
| 339 | (psw "/*@if ") |
| 340 | (ps-print test) |
| 341 | (incf *indent-level*) |
| 342 | (dolist (form body) |
| 343 | (newline-and-indent) (ps-print form) (psw #\;)) |
| 344 | (decf *indent-level*) |
| 345 | (newline-and-indent) |
| 346 | (psw "@end @*/")) |
| 347 | |
| 348 | (defprinter js:instanceof (value type) |
| 349 | (psw #\() |
| 350 | (if (> (expression-precedence value) (op-precedence 'js:instanceof)) |
| 351 | (parenthesize-print value) |
| 352 | (ps-print value)) |
| 353 | (psw " instanceof ") |
| 354 | (if (> (expression-precedence type) (op-precedence 'js:instanceof)) |
| 355 | (parenthesize-print type) |
| 356 | (ps-print type)) |
| 357 | (psw #\))) |
| 358 | |
| 359 | (defprinter js:escape (literal-js) |
| 360 | ;; literal-js should be a form that evaluates to a string containing valid JavaScript |
| 361 | (psw literal-js)) |
| 362 | |
| 363 | ;;; named statements |
| 364 | (defprinter js:throw (x) |
| 365 | (psw "throw ") (ps-print x)) |
| 366 | |
| 367 | (defprinter js:return (x) |
| 368 | (psw "return ") (ps-print x)) |