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 ;;; try-catch
 553 (define-js-special-form try (body &rest clauses)
 554   (let ((body (js-compile-to-body body :indent "  "))
 555         (catch (cdr (assoc :catch clauses)))
 556         (finally (cdr (assoc :finally clauses))))
 557     (assert (not (cdar catch)) nil "Sorry, currently only simple catch forms are supported.")
 558     (make-instance 'js-try
 559                    :body body
 560                    :catch (when catch (list (js-compile-to-symbol (caar catch))
 561                                             (js-compile-to-body (cons 'progn (cdr catch))
 562                                                                 :indent "  ")))
 563                    :finally (when finally (js-compile-to-body (cons 'progn finally)
 564                                                               :indent "  ")))))
 565 ;;; regex
 566 (define-js-special-form regex (regex)
 567   (make-instance 'regex :value (string regex)))
 568
 569 ;;; TODO instanceof
 570 (define-js-special-form instanceof (value type)
 571   (make-instance 'js-instanceof
 572                  :value (js-compile-to-expression value)
 573                  :type (js-compile-to-expression type)))
 574
 575 ;;; single operations
 576 (defmacro define-parse-js-single-op (name &optional (superclass 'expression))
 577   (let ((js-name (intern (concatenate 'string "JS-" (symbol-name name)) #.*package*)))
 578     `(define-js-special-form ,name (value)
 579        (make-instance ',js-name :value (js-compile-to-expression value)))
 580     ))
 581
 582 (define-parse-js-single-op return statement)
 583 (define-parse-js-single-op throw statement)
 584 (define-parse-js-single-op delete)
 585 (define-parse-js-single-op void)
 586 (define-parse-js-single-op typeof)
 587 (define-parse-js-single-op new)
 588
 589 ;;; conditional compilation
 590 (define-js-special-form cc-if (test &rest body)
 591   (make-instance 'cc-if :test test
 592                  :body (mapcar #'js-compile body)))
 593
 594 ;;; standard macros
 595 (defjsmacro with-slots (slots object &rest body)
 596   `(symbol-macrolet ,(mapcar #'(lambda (slot)
 597                                  `(,slot '(slot-value ,object ',slot)))
 598                              slots)
 599     ,@body))
 600
 601 (defjsmacro when (test &rest body)
 602   `(if ,test (progn ,@body)))
 603
 604 (defjsmacro unless (test &rest body)
 605   `(if (not ,test) (progn ,@body)))
 606
 607 (defjsmacro 1- (form)
 608   `(- ,form 1))
 609
 610 (defjsmacro 1+ (form)
 611   `(+ ,form 1))
 612
 613 ;;; macros
 614 (defmacro with-temp-macro-environment ((var) &body body)
 615   `(let* ((,var (make-macro-env-dictionary))
 616           (*js-macro-env* (cons ,var *js-macro-env*)))
 617     ,@body))
 618
 619 (define-js-special-form macrolet (macros &body body)
 620   (with-temp-macro-environment (macro-env-dict)
 621     (dolist (macro macros)
 622       (destructuring-bind (name arglist &body body)
 623           macro
 624         (setf (get-macro-spec name macro-env-dict)
 625               (cons nil (let ((args (gensym "ps-macrolet-args-")))
 626                           (compile nil `(lambda (&rest ,args)
 627                                          (destructuring-bind ,arglist
 628                                              ,args
 629                                            ,@body))))))))
 630     (js-compile `(progn ,@body))))
 631
 632 (define-js-special-form symbol-macrolet (symbol-macros &body body)
 633   (with-temp-macro-environment (macro-env-dict)
 634     (dolist (macro symbol-macros)
 635       (destructuring-bind (name &body expansion)
 636           macro
 637         (setf (get-macro-spec name macro-env-dict)
 638               (cons t (compile nil `(lambda () ,@expansion))))))
 639     (js-compile `(progn ,@body))))
 640
 641 (defjsmacro defmacro (name args &body body)
 642   `(lisp (defjsmacro ,name ,args ,@body) nil))
 643
 644 (defjsmacro lisp (&body forms)
 645   "Evaluates the given forms in Common Lisp at ParenScript
 646 macro-expansion time. The value of the last form is treated as a
 647 ParenScript expression and is inserted into the generated Javascript
 648 (use nil for no-op)."
 649   (eval (cons 'progn forms)))
 650
 651 ;;; Math library
 652 (defjsmacro floor (expr)
 653   `(*Math.floor ,expr))
 654
 655 (defjsmacro random ()
 656   `(*Math.random))
 657
 658 (defjsmacro evenp (num)
 659   `(= (% ,num 2) 0))
 660
 661 (defjsmacro oddp (num)
 662   `(= (% ,num 2) 1))
 663
 664 ;;; helper macros
 665 (define-js-special-form js (&rest body)
 666   (make-instance 'string-literal
 667                  :value (string-join (js-to-statement-strings
 668                                       (js-compile (cons 'progn body)) 0) " ")))
 669
 670 (define-js-special-form js-inline (&rest body)
 671   (make-instance 'string-literal
 672                  :value (concatenate
 673                          'string
 674                          "javascript:"
 675                          (string-join (js-to-statement-strings
 676                                        (js-compile (cons 'progn body)) 0) " "))))
 677
 678 ;;;; compiler interface ;;;;
 679 (defun js-compile (form)
 680   (setf form (js-expand-form form))
 681   (cond ((stringp form)
 682          (make-instance 'string-literal :value form))
 683         ((characterp form)
 684          (make-instance 'string-literal :value (string form)))
 685         ((numberp form)
 686          (make-instance 'number-literal :value form))
 687         ((symbolp form)
 688          (let ((c-macro (js-get-special-form form)))
 689            (if c-macro
 690                (funcall c-macro)
 691                (make-instance 'js-variable :value form))))
 692         ((and (consp form)
 693               (eql (first form) 'quote))
 694          (make-instance 'js-quote :value (second form)))
 695         ((consp form)
 696          (js-compile-list form))
 697         (t (error "Unknown atomar expression ~S" form))))
 698
 699 (defun js-compile-list (form)
 700   (let* ((name (car form))
 701          (args (cdr form))
 702          (js-form (js-get-special-form name)))
 703     (cond (js-form
 704            (apply js-form args))
 705
 706           ((op-form-p form)
 707            (make-instance 'op-form
 708                           :operator (js-convert-op-name (js-compile-to-symbol (first form)))
 709                           :args (mapcar #'js-compile-to-expression (rest form))))
 710
 711           ((method-call-p form)
 712            (make-instance 'method-call
 713                           :method (js-compile-to-symbol (first form))
 714                           :object (js-compile-to-expression (second form))
 715                           :args (mapcar #'js-compile-to-expression (cddr form))))
 716
 717           ((funcall-form-p form)
 718            (make-instance 'function-call
 719                           :function (js-compile-to-expression (first form))
 720                           :args (mapcar #'js-compile-to-expression (rest form))))
 721
 722           (t (error "Unknown form ~S" form)))))
 723
 724 (defun js-compile-to-expression (form)
 725   (let ((res (js-compile form)))
 726     (assert (typep res 'expression))
 727     res))
 728
 729 (defun js-compile-to-symbol (form)
 730   (let ((res (js-compile form)))
 731     (when (typep res 'js-variable)
 732       (setf res (value res)))
 733     (assert (symbolp res) ()
 734             "~a is expected to be a symbol, but compiles to ~a. This could be due to ~a being a special form." form res form)
 735     res))
 736
 737 (defun js-compile-to-statement (form)
 738   (let ((res (js-compile form)))
 739     (assert (typep res 'statement))
 740     res))
 741
 742 (defun js-compile-to-body (form &key (indent ""))
 743   (let ((res (js-compile-to-statement form)))
 744     (if (typep res 'js-body)
 745         (progn (setf (b-indent res) indent)
 746                res)
 747         (make-instance 'js-body
 748                        :indent indent
 749                        :stmts (list res)))))
 750
 751 (defmacro js (&rest body)
 752   `(js* '(progn ,@body)))
 753
 754 (defmacro js* (&rest body)
 755   "Return the javascript string representing BODY.
 756
 757 Body is evaluated."
 758   `(string-join
 759     (js-to-statement-strings (js-compile (list 'progn ,@body)) 0)
 760     (string #\Newline)))
 761
 762 (defun js-to-string (expr)
 763   (string-join
 764    (js-to-statement-strings (js-compile expr) 0)
 765    (string #\Newline)))
 766
 767 (defun js-to-line (expr)
 768   (string-join
 769    (js-to-statement-strings (js-compile expr) 0) " "))
 770
 771 (defmacro js-file (&rest body)
 772   `(html
 773     (:princ
 774      (js ,@body))))
 775
 776 (defmacro js-script (&rest body)
 777   `((:script :type "text/javascript")
 778     (:princ (format nil "~%// <![CDATA[~%"))
 779     (:princ (js ,@body))
 780     (:princ (format nil "~%// ]]>~%"))))
 781
 782 (defmacro js-inline (&rest body)
 783   `(js-inline* '(progn ,@body)))
 784
 785 (defmacro js-inline* (&rest body)
 786   "Just like JS-INLINE except that BODY is evaluated before being
 787 converted to javascript."
 788   `(concatenate 'string "javascript:"
 789     (string-join (js-to-statement-strings (js-compile (list 'progn ,@body)) 0) " ")))
 790
 791