src/parser.lisp

   1 (in-package :parenscript)
   2
   3 ;;; special forms
   4
   5 (eval-when (:compile-toplevel :load-toplevel :execute)
   6   (defvar *js-special-forms* (make-hash-table :test 'equal)
   7         "A hash-table containing functions that implement ParenScript
   8 special forms, indexed by name (a string).")
   9
  10   (defun undefine-js-special-form (name)
  11     (when (gethash (symbol-name name) *js-special-forms*)
  12       (warn "Redefining ParenScript special form ~S" name)
  13       (remhash (symbol-name name) *js-special-forms*))))
  14
  15 (defmacro define-js-special-form (name lambda-list &rest body)
  16   "Define a special form NAME. Arguments are destructured according to
  17 LAMBDA-LIST. The resulting JS language types are appended to the
  18 ongoing javascript compilation."
  19   (let ((js-name (intern (concatenate 'string "JS-" (symbol-name name)) #.*package*))
  20         (arglist (gensym "ps-arglist-")))
  21     `(eval-when (:compile-toplevel :load-toplevel :execute)
  22       (defun ,js-name (&rest ,arglist)
  23         (destructuring-bind ,lambda-list
  24             ,arglist
  25           ,@body))
  26       (setf (gethash ,(symbol-name name) *js-special-forms*) #',js-name))))
  27
  28 (defun js-special-form-p (form)
  29   (and (consp form)
  30        (symbolp (car form))
  31        (gethash (symbol-name (car form)) *js-special-forms*)))
  32
  33 (defun js-get-special-form (name)
  34   (when (symbolp name)
  35     (gethash (symbol-name name) *js-special-forms*)))
  36
  37 ;;; macro expansion
  38
  39 (eval-when (:compile-toplevel :load-toplevel :execute)
  40   (defun make-macro-env-dictionary ()
  41     (make-hash-table :test 'equal))
  42
  43   (defvar *js-macro-toplevel* (make-macro-env-dictionary)
  44     "Toplevel macro environment dictionary. Key is symbol-name of the macro, value is (symbol-macro-p . expansion-function).")
  45   (defvar *js-macro-env* (list *js-macro-toplevel*)
  46     "Current macro environment."))
  47
  48 (defmacro get-macro-spec (name env-dict)
  49   `(gethash (symbol-name ,name) ,env-dict))
  50
  51 (defun lookup-macro-spec (name &optional (environment *js-macro-env*))
  52   (when (symbolp name)
  53     (do ((env environment (cdr env)))
  54         ((null env) nil)
  55       (let ((val (get-macro-spec name (car env))))
  56         (when val
  57           (return-from lookup-macro-spec
  58             (values val (or (cdr env)
  59                             (list *js-macro-toplevel*)))))))))
  60
  61 (defun symbol-macro-p (name &optional (environment *js-macro-env*))
  62   (and (symbolp name) (car (lookup-macro-spec name environment))))
  63
  64 (defun macro-p (name &optional (environment *js-macro-env*))
  65   (and (symbolp name) (let ((macro-spec (lookup-macro-spec name environment)))
  66                         (and macro-spec (not (car macro-spec))))))
  67
  68 (defun lookup-macro-expansion-function (name &optional (environment *js-macro-env*))
  69   "Lookup NAME in the given macro expansion environment (which
  70 defaults to the current macro environment). Returns the expansion
  71 function and the parent macro environment of the macro."
  72   (multiple-value-bind (macro-spec parent-env)
  73       (lookup-macro-spec name environment)
  74     (values (cdr macro-spec) parent-env)))
  75
  76 (defmacro defjsmacro (name args &rest body)
  77   "Define a ParenScript macro, and store it in the toplevel ParenScript macro environment."
  78   (let ((lambda-list (gensym "ps-lambda-list-"))
  79         (body (if (stringp (first body)) (rest body) body))) ;; drop docstring
  80     (undefine-js-special-form name)
  81     `(setf (get-macro-spec ',name *js-macro-toplevel*)
  82       (cons nil (lambda (&rest ,lambda-list)
  83                   (destructuring-bind ,args
  84                       ,lambda-list
  85                     ,@body))))))
  86
  87 (defmacro defmacro/js (name args &body body)
  88   "Define a Lisp macro and import it into the ParenScript macro environment."
  89   `(progn (defmacro ,name ,args ,@body)
  90           (js:import-macros-from-lisp ',name)))
  91
  92 (defmacro defmacro+js (name args &body body)
  93   "Define a Lisp macro and a ParenScript macro in their respective
  94 macro environments. This function should be used when you want to use
  95 the same macro in both Lisp and ParenScript, but the 'macroexpand' of
  96 that macro in Lisp makes the Lisp macro unsuitable to be imported into
  97 the ParenScript macro environment."
  98   `(progn (defmacro ,name ,args ,@body)
  99           (js:defjsmacro ,name ,args ,@body)))
 100
 101 (defun import-macros-from-lisp (&rest names)
 102   "Import the named Lisp macros into the ParenScript macro environment."
 103   (dolist (name names)
 104     (let ((name name))
 105       (undefine-js-special-form name)
 106       (setf (get-macro-spec name *js-macro-toplevel*)
 107             (cons nil (lambda (&rest args)
 108                         (macroexpand `(,name ,@args))))))))
 109
 110 (defun js-expand-form (expr)
 111   (if (consp expr)
 112       (let ((op (car expr))
 113             (args (cdr expr)))
 114         (cond ((equal op 'quote) expr)
 115               ((macro-p op) (multiple-value-bind (expansion-function macro-env)
 116                                 (lookup-macro-expansion-function op)
 117                               (js-expand-form (let ((*js-macro-env* macro-env))
 118                                                 (apply expansion-function args)))))
 119               (t expr)))
 120       (cond ((js-special-form-p expr) expr)
 121             ((symbol-macro-p expr) (multiple-value-bind (expansion-function macro-env)
 122                                        (lookup-macro-expansion-function expr)
 123                                      (js-expand-form (let ((*js-macro-env* macro-env))
 124                                                        (funcall expansion-function)))))
 125             (t expr))))
 126
 127 (defvar *gen-js-name-counter* 0)
 128
 129 (defun gen-js-name-string (&key (prefix "_ps_"))
 130   "Generates a unique valid javascript identifier ()"
 131   (concatenate 'string
 132                prefix (princ-to-string (incf *gen-js-name-counter*))))
 133
 134 (defun gen-js-name (&key (prefix "_ps_"))
 135   "Generate a new javascript identifier."
 136   (intern (gen-js-name-string :prefix prefix)
 137           (find-package :js)))
 138
 139 (defmacro with-unique-js-names (symbols &body body)
 140   "Evaluate BODY with the variables on SYMBOLS bound to new javascript identifiers.
 141
 142 Each element of SYMBOLS is either a symbol or a list of (symbol
 143 prefix)."
 144   `(let* ,(mapcar (lambda (symbol)
 145                     (destructuring-bind (symbol &optional prefix)
 146                         (if (consp symbol)
 147                             symbol
 148                             (list symbol))
 149                       (if prefix
 150                           `(,symbol (gen-js-name :prefix ,prefix))
 151                           `(,symbol (gen-js-name)))))
 152                   symbols)
 153      ,@body))
 154
 155 (defjsmacro rebind (variables expression)
 156   "Creates a new js lexical environment and copies the given
 157   variable(s) there.  Executes the body in the new environment. This
 158   has the same effect as a new (let () ...) form in lisp but works on
 159   the js side for js closures."
 160   (unless (listp variables)
 161     (setf variables (list variables)))
 162   `((lambda ()
 163       (let ((new-context (new *object)))
 164         ,@(loop for variable in variables
 165                 do (setf variable (symbol-to-js variable))
 166                 collect `(setf (slot-value new-context ,variable) (slot-value this ,variable)))
 167         (with new-context
 168               (return ,expression))))))
 169
 170 (defvar *var-counter* 0)
 171
 172 (defun js-gensym (&optional (name "js"))
 173   (intern (format nil "tmp-~A-~A" name (incf *var-counter*)) #.*package*))
 174
 175 ;;; reserved Javascript keywords
 176
 177 (defvar *reserved-javascript-keywords*
 178   '("abstract" "else" "instanceof" "switch" "boolean" "enum" "int" "synchronized"
 179     "break" "export" "interface" "this" "byte" "extends" "long" "throw" "case"
 180     "native" "throws" "catch" "final" "new" "transient" "char" "finally" "float"
 181     "package" "try" "const" "for" "private" "typeof" "continue" "function"
 182     "protected" "var" "debugger" "goto" "public" "void" "default" "if" "return"
 183     "volatile" "delete" "implements" "short" "while" "do" "import" "static" "with"
 184     "double" "in" "super" "class"))
 185
 186 (defun reserved-identifier-p (id-string)
 187   (find id-string *reserved-javascript-keywords* :test #'string-equal))
 188
 189 (defmethod initialize-instance :after ((var js-variable) &rest initargs)
 190   (declare (ignore initargs))
 191   (when (reserved-identifier-p (slot-value var 'value))
 192     (warn "~a is a reserved Javascript keyword and should not be used as a variable or function name." (slot-value var 'value))))
 193
 194 ;;; literals
 195
 196 (defmacro defjsliteral (name string)
 197   "Define a Javascript literal that will expand to STRING."
 198   `(define-js-special-form ,name () (make-instance 'expression :value ,string)))
 199
 200 (defjsliteral this      "this")
 201 (defjsliteral t         "true")
 202 (defjsliteral nil       "null")
 203 (defjsliteral false     "false")
 204 (defjsliteral undefined "undefined")
 205
 206 (defmacro defjskeyword (name string)
 207   "Define a Javascript keyword that will expand to STRING."
 208   `(define-js-special-form ,name () (make-instance 'statement :value ,string)))
 209
 210 (defjskeyword break    "break")
 211 (defjskeyword continue "continue")
 212
 213 ;;; array literals
 214
 215 (define-js-special-form array (&rest values)
 216   (make-instance 'array-literal
 217                  :values (mapcar #'js-compile-to-expression values)))
 218
 219 (defjsmacro list (&rest values)
 220   `(array ,@values))
 221
 222 (define-js-special-form aref (array &rest coords)
 223   (make-instance 'js-aref
 224                  :array (js-compile-to-expression array)
 225                  :index (mapcar #'js-compile-to-expression coords)))
 226
 227
 228 (defjsmacro make-array (&rest inits)
 229   `(new (*array ,@inits)))
 230
 231 ;;; object literals (maps and hash-tables)
 232
 233 (define-js-special-form {} (&rest values)
 234   (make-instance 'object-literal
 235                  :values (loop
 236                             for (key value) on values by #'cddr
 237                             collect (cons key (js-compile-to-expression value)))))
 238
 239 ;;; operators
 240 (define-js-special-form ++ (x)
 241   (make-instance 'one-op :pre-p nil :op "++"
 242                  :value (js-compile-to-expression x)))
 243
 244 (define-js-special-form -- (x)
 245   (make-instance 'one-op :pre-p nil :op "--"
 246                  :value (js-compile-to-expression x)))
 247
 248 (define-js-special-form incf (x &optional (delta 1))
 249   (if (eql delta 1)
 250       (make-instance 'one-op :pre-p t :op "++"
 251                      :value (js-compile-to-expression x))
 252       (make-instance 'op-form
 253                      :operator '+=
 254                      :args (mapcar #'js-compile-to-expression
 255                                    (list x delta )))))
 256
 257 (define-js-special-form decf (x &optional (delta 1))
 258   (if (eql delta 1)
 259       (make-instance 'one-op :pre-p t :op "--"
 260                      :value (js-compile-to-expression x))
 261       (make-instance 'op-form
 262                      :operator '-=
 263                      :args (mapcar #'js-compile-to-expression
 264                                    (list x delta )))))
 265
 266 (define-js-special-form - (first &rest rest)
 267   (if (null rest)
 268       (make-instance 'one-op
 269                      :pre-p t
 270                      :op "-"
 271                      :value (js-compile-to-expression first))
 272       (make-instance 'op-form
 273                      :operator '-
 274                      :args (mapcar #'js-compile-to-expression
 275                                    (cons first rest)))))
 276
 277 (define-js-special-form not (x)
 278   (let ((value (js-compile-to-expression x)))
 279     (if (and (typep value 'op-form)
 280              (= (length (op-args value)) 2))
 281         (let ((new-op (case (operator value)
 282                         (== '!=)
 283                         (< '>=)
 284                         (> '<=)
 285                         (<= '>)
 286                         (>= '<)
 287                         (!= '==)
 288                         (=== '!==)
 289                         (!== '===)
 290                         (t nil))))
 291           (if new-op
 292               (make-instance 'op-form :operator new-op
 293                              :args (op-args value))
 294               (make-instance 'one-op :pre-p t :op "!"
 295                             :value value)))
 296         (make-instance 'one-op :pre-p t :op "!"
 297                        :value value))))
 298
 299 (define-js-special-form ~ (x)
 300   (let ((expr (js-compile-to-expression x)))
 301     (make-instance 'one-op :pre-p t :op "~" :value expr)))
 302
 303 ;;; function calls
 304
 305 (defun funcall-form-p (form)
 306   (and (listp form)
 307        (not (op-form-p form))
 308        (not (js-special-form-p form))))
 309
 310 (defun method-call-p (form)
 311   (and (funcall-form-p form)
 312        (symbolp (first form))
 313        (eql (char (symbol-name (first form)) 0) #\.)))
 314
 315 ;;; progn
 316
 317 (define-js-special-form progn (&rest body)
 318   (make-instance 'js-body
 319                  :stmts (mapcar #'js-compile-to-statement body)))
 320
 321 (defmethod expression-precedence ((body js-body))
 322   (if (= (length (b-stmts body)) 1)
 323       (expression-precedence (first (b-stmts body)))
 324       (op-precedence 'comma)))
 325
 326 ;;; function definition
 327 (define-js-special-form lambda (args &rest body)
 328   (make-instance 'js-lambda
 329                  :args (mapcar #'js-compile-to-symbol args)
 330                  :body (make-instance 'js-body
 331                                       :indent "  "
 332                                       :stmts (mapcar #'js-compile-to-statement body))))
 333
 334 (define-js-special-form defun (name args &rest body)
 335   (make-instance 'js-defun
 336                  :name (js-compile-to-symbol name)
 337                  :args (mapcar #'js-compile-to-symbol args)
 338                  :body (make-instance 'js-body
 339                                       :indent "  "
 340                                       :stmts (mapcar #'js-compile-to-statement body))))
 341
 342 ;;; object creation
 343 (define-js-special-form create (&rest args)
 344   (make-instance 'js-object
 345                  :slots (loop for (name val) on args by #'cddr
 346                               collect (let ((name-expr (js-compile-to-expression name)))
 347                                         (assert (or (typep name-expr 'js-variable)
 348                                                     (typep name-expr 'string-literal)
 349                                                     (typep name-expr 'number-literal)))
 350                                         (list name-expr (js-compile-to-expression val))))))
 351
 352
 353 (define-js-special-form slot-value (obj slot)
 354   (make-instance 'js-slot-value :object (js-compile-to-expression obj)
 355                    :slot (js-compile slot)))
 356
 357 ;;; cond
 358 (define-js-special-form cond (&rest clauses)
 359   (make-instance 'js-cond
 360                  :tests (mapcar (lambda (clause) (js-compile-to-expression (car clause)))
 361                                 clauses)
 362                  :bodies (mapcar (lambda (clause) (js-compile-to-body (cons 'progn (cdr clause)) :indent "  "))
 363                                  clauses)))
 364
 365 ;;; if
 366 (define-js-special-form if (test then &optional else)
 367   (make-instance 'js-if :test (js-compile-to-expression test)
 368                  :then (js-compile-to-body then :indent "  ")
 369                  :else (when else
 370                          (js-compile-to-body else :indent "  "))))
 371
 372 (defmethod expression-precedence ((if js-if))
 373   (op-precedence 'if))
 374
 375 ;;; switch
 376 (define-js-special-form switch (value &rest clauses)
 377   (let ((clauses (mapcar #'(lambda (clause)
 378                              (let ((val (first clause))
 379                                    (body (cdr clause)))
 380                                (list (if (eql val 'default)
 381                                          'default
 382                                          (js-compile-to-expression val))
 383                                      (js-compile-to-body (cons 'progn body) :indent "  "))))
 384                          clauses))
 385         (check (js-compile-to-expression value)))
 386     (make-instance 'js-switch :value check
 387                    :clauses clauses)))
 388
 389
 390 (defjsmacro case (value &rest clauses)
 391   (labels ((make-clause (val body more)
 392              (cond ((listp val)
 393                     (append (mapcar #'list (butlast val))
 394                             (make-clause (first (last val)) body more)))
 395                    ((member val '(t otherwise))
 396                     (make-clause 'default body more))
 397                    (more `((,val ,@body break)))
 398                    (t `((,val ,@body))))))
 399     `(switch ,value ,@(mapcon #'(lambda (x)
 400                                   (make-clause (car (first x))
 401                                                (cdr (first x))
 402                                                (rest x)))
 403                               clauses))))
 404
 405 ;;; assignment
 406 (defun assignment-op (op)
 407   (case op
 408     (+ '+=)
 409     (~ '~=)
 410     (\& '\&=)
 411     (\| '\|=)
 412     (- '-=)
 413     (* '*=)
 414     (% '%=)
 415     (>> '>>=)
 416     (^  '^=)
 417     (<< '<<=)
 418     (>>> '>>>=)
 419     (/   '/=)
 420     (t   nil)))
 421
 422 (defun make-js-test (lhs rhs)
 423   (if (and (typep rhs 'op-form)
 424            (member lhs (op-args rhs) :test #'js-equal))
 425       (let ((args-without (remove lhs (op-args rhs)
 426                                   :count 1 :test #'js-equal))
 427             (args-without-first (remove lhs (op-args rhs)
 428                                         :count 1 :end 1
 429                                         :test #'js-equal))
 430             (one (list (make-instance 'number-literal :value 1))))
 431         #+nil
 432         (format t "OPERATOR: ~S, ARGS-WITHOUT: ~S, ARGS-WITHOUT-FIRST ~S~%"
 433                 (operator rhs)
 434                 args-without
 435                 args-without-first)
 436         (cond ((and (js-equal args-without one)
 437                     (eql (operator rhs) '+))
 438                (make-instance 'one-op :pre-p nil :op "++"
 439                               :value lhs))
 440               ((and (js-equal args-without-first one)
 441                     (eql (operator rhs) '-))
 442                (make-instance 'one-op :pre-p nil :op "--"
 443                               :value lhs))
 444               ((and (assignment-op (operator rhs))
 445                     (member (operator rhs)
 446                             '(+ *))
 447                     (js-equal lhs (first (op-args rhs))))
 448                (make-instance 'op-form
 449                               :operator (assignment-op (operator rhs))
 450                               :args (list lhs (make-instance 'op-form
 451                                                              :operator (operator rhs)
 452                                                              :args args-without-first))))
 453               ((and (assignment-op (operator rhs))
 454                     (js-equal (first (op-args rhs)) lhs))
 455                (make-instance 'op-form
 456                               :operator (assignment-op (operator rhs))
 457                               :args (list lhs (make-instance 'op-form
 458                                                              :operator (operator rhs)
 459                                                              :args (cdr (op-args rhs))))))
 460               (t (make-instance 'js-setf :lhs lhs :rhsides (list rhs)))))
 461       (make-instance 'js-setf :lhs lhs :rhsides (list rhs))))
 462
 463 (define-js-special-form setf (&rest args)
 464   (let ((assignments (loop for (lhs rhs) on args by #'cddr
 465                            for rexpr = (js-compile-to-expression rhs)
 466                            for lexpr = (js-compile-to-expression lhs)
 467                            collect (make-js-test lexpr rexpr))))
 468     (if (= (length assignments) 1)
 469         (first assignments)
 470         (make-instance 'js-body :indent "" :stmts assignments))))
 471
 472 (defmethod expression-precedence ((setf js-setf))
 473   (op-precedence '=))
 474
 475 ;;; defvar
 476 (define-js-special-form defvar (name &optional value)
 477   (make-instance 'js-defvar :names (list (js-compile-to-symbol name))
 478                  :value (when value (js-compile-to-expression value))))
 479
 480 ;;; let
 481 (define-js-special-form let (decls &rest body)
 482   (let ((defvars (mapcar #'(lambda (decl)
 483                              (if (atom decl)
 484                                  (make-instance 'js-defvar
 485                                        :names (list (js-compile-to-symbol decl))
 486                                        :value nil)
 487                                  (let ((name (first decl))
 488                                        (value (second decl)))
 489                                    (make-instance 'js-defvar
 490                                                   :names (list (js-compile-to-symbol name))
 491                                                   :value (js-compile-to-expression value)))))
 492                          decls)))
 493     (make-instance 'js-sub-body
 494                    :indent "  "
 495                    :stmts (nconc defvars
 496                                  (mapcar #'js-compile-to-statement body)))))
 497
 498 ;;; iteration
 499 (defun make-for-vars (decls)
 500   (loop for decl in decls
 501         for var = (if (atom decl) decl (first decl))
 502         for init = (if (atom decl) nil (second decl))
 503         collect (make-instance 'js-defvar :names (list (js-compile-to-symbol var))
 504                                :value (js-compile-to-expression init))))
 505
 506 (defun make-for-steps (decls)
 507   (loop for decl in decls
 508         when (= (length decl) 3)
 509         collect (js-compile-to-expression (third decl))))
 510
 511 (define-js-special-form do (decls termination &rest body)
 512   (let ((vars (make-for-vars decls))
 513         (steps (make-for-steps decls))
 514         (check (js-compile-to-expression (list 'not (first termination))))
 515         (body (js-compile-to-body (cons 'progn body) :indent "  ")))
 516     (make-instance 'js-for
 517                    :vars vars
 518                    :steps steps
 519                    :check check
 520                    :body body)))
 521
 522 (defjsmacro dotimes (iter &rest body)
 523   (let ((var (first iter))
 524         (times (second iter)))
 525   `(do ((,var 0 (1+ ,var)))
 526        ((>= ,var ,times))
 527      ,@body)))
 528
 529 (defjsmacro dolist (i-array &rest body)
 530   (let ((var (first i-array))
 531         (array (second i-array))
 532         (arrvar (js-gensym "arr"))
 533         (idx (js-gensym "i")))
 534     `(let ((,arrvar ,array))
 535       (do ((,idx 0 (1+ ,idx)))
 536           ((>= ,idx (slot-value ,arrvar 'length)))
 537         (let ((,var (aref ,arrvar ,idx)))
 538           ,@body)))))
 539
 540 (define-js-special-form doeach (decl &rest body)
 541   (make-instance 'for-each :name (js-compile-to-symbol (first decl))
 542                  :value (js-compile-to-expression (second decl))
 543                  :body (js-compile-to-body (cons 'progn body) :indent "  ")))
 544
 545 (define-js-special-form while (check &rest body)
 546   (make-instance 'js-while
 547                  :check (js-compile-to-expression check)
 548                  :body (js-compile-to-body (cons 'progn body) :indent "  ")))
 549
 550 ;;; with
 551
 552 (define-js-special-form with (statement &rest body)
 553   (make-instance 'js-with
 554                  :obj (js-compile-to-expression statement)
 555                  :body (js-compile-to-body (cons 'progn body) :indent "  ")))
 556
 557 ;;; try-catch
 558 (define-js-special-form try (body &rest clauses)
 559   (let ((body (js-compile-to-body body :indent "  "))
 560         (catch (cdr (assoc :catch clauses)))
 561         (finally (cdr (assoc :finally clauses))))
 562     (assert (not (cdar catch)) nil "Sorry, currently only simple catch forms are supported.")
 563     (make-instance 'js-try
 564                    :body body
 565                    :catch (when catch (list (js-compile-to-symbol (caar catch))
 566                                             (js-compile-to-body (cons 'progn (cdr catch))
 567                                                                 :indent "  ")))
 568                    :finally (when finally (js-compile-to-body (cons 'progn finally)
 569                                                               :indent "  ")))))
 570 ;;; regex
 571 (define-js-special-form regex (regex)
 572   (make-instance 'regex :value (string regex)))
 573
 574 ;;; TODO instanceof
 575 (define-js-special-form instanceof (value type)
 576   (make-instance 'js-instanceof
 577                  :value (js-compile-to-expression value)
 578                  :type (js-compile-to-expression type)))
 579
 580 ;;; single operations
 581 (defmacro define-parse-js-single-op (name &optional (superclass 'expression))
 582   (let ((js-name (intern (concatenate 'string "JS-" (symbol-name name)) #.*package*)))
 583     `(define-js-special-form ,name (value)
 584        (make-instance ',js-name :value (js-compile-to-expression value)))
 585     ))
 586
 587 (define-parse-js-single-op return statement)
 588 (define-parse-js-single-op throw statement)
 589 (define-parse-js-single-op delete)
 590 (define-parse-js-single-op void)
 591 (define-parse-js-single-op typeof)
 592 (define-parse-js-single-op new)
 593
 594 ;;; conditional compilation
 595 (define-js-special-form cc-if (test &rest body)
 596   (make-instance 'cc-if :test test
 597                  :body (mapcar #'js-compile body)))
 598
 599 ;;; standard macros
 600 (defjsmacro with-slots (slots object &rest body)
 601   `(symbol-macrolet ,(mapcar #'(lambda (slot)
 602                                  `(,slot '(slot-value ,object ',slot)))
 603                              slots)
 604     ,@body))
 605
 606 (defjsmacro when (test &rest body)
 607   `(if ,test (progn ,@body)))
 608
 609 (defjsmacro unless (test &rest body)
 610   `(if (not ,test) (progn ,@body)))
 611
 612 (defjsmacro 1- (form)
 613   `(- ,form 1))
 614
 615 (defjsmacro 1+ (form)
 616   `(+ ,form 1))
 617
 618 ;;; macros
 619 (defmacro with-temp-macro-environment ((var) &body body)
 620   `(let* ((,var (make-macro-env-dictionary))
 621           (*js-macro-env* (cons ,var *js-macro-env*)))
 622     ,@body))
 623
 624 (define-js-special-form macrolet (macros &body body)
 625   (with-temp-macro-environment (macro-env-dict)
 626     (dolist (macro macros)
 627       (destructuring-bind (name arglist &body body)
 628           macro
 629         (setf (get-macro-spec name macro-env-dict)
 630               (cons nil (let ((args (gensym "ps-macrolet-args-")))
 631                           (compile nil `(lambda (&rest ,args)
 632                                          (destructuring-bind ,arglist
 633                                              ,args
 634                                            ,@body))))))))
 635     (js-compile `(progn ,@body))))
 636
 637 (define-js-special-form symbol-macrolet (symbol-macros &body body)
 638   (with-temp-macro-environment (macro-env-dict)
 639     (dolist (macro symbol-macros)
 640       (destructuring-bind (name &body expansion)
 641           macro
 642         (setf (get-macro-spec name macro-env-dict)
 643               (cons t (compile nil `(lambda () ,@expansion))))))
 644     (js-compile `(progn ,@body))))
 645
 646 (defjsmacro defmacro (name args &body body)
 647   `(lisp (defjsmacro ,name ,args ,@body) nil))
 648
 649 (defjsmacro lisp (&body forms)
 650   "Evaluates the given forms in Common Lisp at ParenScript
 651 macro-expansion time. The value of the last form is treated as a
 652 ParenScript expression and is inserted into the generated Javascript
 653 (use nil for no-op)."
 654   (eval (cons 'progn forms)))
 655
 656 ;;; Math library
 657 (defjsmacro floor (expr)
 658   `(*Math.floor ,expr))
 659
 660 (defjsmacro random ()
 661   `(*Math.random))
 662
 663 (defjsmacro evenp (num)
 664   `(= (% ,num 2) 0))
 665
 666 (defjsmacro oddp (num)
 667   `(= (% ,num 2) 1))
 668
 669 ;;; helper macros
 670 (define-js-special-form js (&rest body)
 671   (make-instance 'string-literal
 672                  :value (string-join (js-to-statement-strings
 673                                       (js-compile (cons 'progn body)) 0) " ")))
 674
 675 (define-js-special-form js-inline (&rest body)
 676   (make-instance 'string-literal
 677                  :value (concatenate
 678                          'string
 679                          "javascript:"
 680                          (string-join (js-to-statement-strings
 681                                        (js-compile (cons 'progn body)) 0) " "))))
 682
 683 ;;;; compiler interface ;;;;
 684 (defun js-compile (form)
 685   (setf form (js-expand-form form))
 686   (cond ((stringp form)
 687          (make-instance 'string-literal :value form))
 688         ((characterp form)
 689          (make-instance 'string-literal :value (string form)))
 690         ((numberp form)
 691          (make-instance 'number-literal :value form))
 692         ((symbolp form)
 693          (let ((c-macro (js-get-special-form form)))
 694            (if c-macro
 695                (funcall c-macro)
 696                (make-instance 'js-variable :value form))))
 697         ((and (consp form)
 698               (eql (first form) 'quote))
 699          (make-instance 'js-quote :value (second form)))
 700         ((consp form)
 701          (js-compile-list form))
 702         (t (error "Unknown atomar expression ~S" form))))
 703
 704 (defun js-compile-list (form)
 705   (let* ((name (car form))
 706          (args (cdr form))
 707          (js-form (js-get-special-form name)))
 708     (cond (js-form
 709            (apply js-form args))
 710
 711           ((op-form-p form)
 712            (make-instance 'op-form
 713                           :operator (js-convert-op-name (js-compile-to-symbol (first form)))
 714                           :args (mapcar #'js-compile-to-expression (rest form))))
 715
 716           ((method-call-p form)
 717            (make-instance 'method-call
 718                           :method (js-compile-to-symbol (first form))
 719                           :object (js-compile-to-expression (second form))
 720                           :args (mapcar #'js-compile-to-expression (cddr form))))
 721
 722           ((funcall-form-p form)
 723            (make-instance 'function-call
 724                           :function (js-compile-to-expression (first form))
 725                           :args (mapcar #'js-compile-to-expression (rest form))))
 726
 727           (t (error "Unknown form ~S" form)))))
 728
 729 (defun js-compile-to-expression (form)
 730   (let ((res (js-compile form)))
 731     (assert (typep res 'expression))
 732     res))
 733
 734 (defun js-compile-to-symbol (form)
 735   (let ((res (js-compile form)))
 736     (when (typep res 'js-variable)
 737       (setf res (value res)))
 738     (assert (symbolp res) ()
 739             "~a is expected to be a symbol, but compiles to ~a. This could be due to ~a being a special form." form res form)
 740     res))
 741
 742 (defun js-compile-to-statement (form)
 743   (let ((res (js-compile form)))
 744     (assert (typep res 'statement))
 745     res))
 746
 747 (defun js-compile-to-body (form &key (indent ""))
 748   (let ((res (js-compile-to-statement form)))
 749     (if (typep res 'js-body)
 750         (progn (setf (b-indent res) indent)
 751                res)
 752         (make-instance 'js-body
 753                        :indent indent
 754                        :stmts (list res)))))
 755
 756 (defmacro js (&rest body)
 757   `(js* '(progn ,@body)))
 758
 759 (defmacro js* (&rest body)
 760   "Return the javascript string representing BODY.
 761
 762 Body is evaluated."
 763   `(string-join
 764     (js-to-statement-strings (js-compile (list 'progn ,@body)) 0)
 765     (string #\Newline)))
 766
 767 (defun js-to-string (expr)
 768   (string-join
 769    (js-to-statement-strings (js-compile expr) 0)
 770    (string #\Newline)))
 771
 772 (defun js-to-line (expr)
 773   (string-join
 774    (js-to-statement-strings (js-compile expr) 0) " "))
 775
 776 (defmacro js-file (&rest body)
 777   `(html
 778     (:princ
 779      (js ,@body))))
 780
 781 (defmacro js-script (&rest body)
 782   `((:script :type "text/javascript")
 783     (:princ (format nil "~%// <![CDATA[~%"))
 784     (:princ (js ,@body))
 785     (:princ (format nil "~%// ]]>~%"))))
 786
 787 (defmacro js-inline (&rest body)
 788   `(js-inline* '(progn ,@body)))
 789
 790 (defmacro js-inline* (&rest body)
 791   "Just like JS-INLINE except that BODY is evaluated before being
 792 converted to javascript."
 793   `(concatenate 'string "javascript:"
 794     (string-join (js-to-statement-strings (js-compile (list 'progn ,@body)) 0) " ")))
 795
 796