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 ;;; literals
 176
 177 (defmacro defjsliteral (name string)
 178   "Define a Javascript literal that will expand to STRING."
 179   `(define-js-special-form ,name () (make-instance 'expression :value ,string)))
 180
 181 (defjsliteral this      "this")
 182 (defjsliteral t         "true")
 183 (defjsliteral nil       "null")
 184 (defjsliteral false     "false")
 185 (defjsliteral undefined "undefined")
 186
 187 (defmacro defjskeyword (name string)
 188   "Define a Javascript keyword that will expand to STRING."
 189   `(define-js-special-form ,name () (make-instance 'statement :value ,string)))
 190
 191 (defjskeyword break    "break")
 192 (defjskeyword continue "continue")
 193
 194 ;;; array literals
 195
 196 (define-js-special-form array (&rest values)
 197   (make-instance 'array-literal
 198                  :values (mapcar #'js-compile-to-expression values)))
 199
 200 (defjsmacro list (&rest values)
 201   `(array ,@values))
 202
 203 (define-js-special-form aref (array &rest coords)
 204   (make-instance 'js-aref
 205                  :array (js-compile-to-expression array)
 206                  :index (mapcar #'js-compile-to-expression coords)))
 207
 208
 209 (defjsmacro make-array (&rest inits)
 210   `(new (*array ,@inits)))
 211
 212 ;;; object literals (maps and hash-tables)
 213
 214 (define-js-special-form {} (&rest values)
 215   (make-instance 'object-literal
 216                  :values (loop
 217                             for (key value) on values by #'cddr
 218                             collect (cons key (js-compile-to-expression value)))))
 219
 220 ;;; operators
 221 (define-js-special-form ++ (x)
 222   (make-instance 'one-op :pre-p nil :op "++"
 223                  :value (js-compile-to-expression x)))
 224
 225 (define-js-special-form -- (x)
 226   (make-instance 'one-op :pre-p nil :op "--"
 227                  :value (js-compile-to-expression x)))
 228
 229 (define-js-special-form incf (x &optional (delta 1))
 230   (if (eql delta 1)
 231       (make-instance 'one-op :pre-p t :op "++"
 232                      :value (js-compile-to-expression x))
 233       (make-instance 'op-form
 234                      :operator '+=
 235                      :args (mapcar #'js-compile-to-expression
 236                                    (list x delta )))))
 237
 238 (define-js-special-form decf (x &optional (delta 1))
 239   (if (eql delta 1)
 240       (make-instance 'one-op :pre-p t :op "--"
 241                      :value (js-compile-to-expression x))
 242       (make-instance 'op-form
 243                      :operator '-=
 244                      :args (mapcar #'js-compile-to-expression
 245                                    (list x delta )))))
 246
 247 (define-js-special-form - (first &rest rest)
 248   (if (null rest)
 249       (make-instance 'one-op
 250                      :pre-p t
 251                      :op "-"
 252                      :value (js-compile-to-expression first))
 253       (make-instance 'op-form
 254                      :operator '-
 255                      :args (mapcar #'js-compile-to-expression
 256                                    (cons first rest)))))
 257
 258 (define-js-special-form not (x)
 259   (let ((value (js-compile-to-expression x)))
 260     (if (and (typep value 'op-form)
 261              (= (length (op-args value)) 2))
 262         (let ((new-op (case (operator value)
 263                         (== '!=)
 264                         (< '>=)
 265                         (> '<=)
 266                         (<= '>)
 267                         (>= '<)
 268                         (!= '==)
 269                         (=== '!==)
 270                         (!== '===)
 271                         (t nil))))
 272           (if new-op
 273               (make-instance 'op-form :operator new-op
 274                              :args (op-args value))
 275               (make-instance 'one-op :pre-p t :op "!"
 276                             :value value)))
 277         (make-instance 'one-op :pre-p t :op "!"
 278                        :value value))))
 279
 280 (define-js-special-form ~ (x)
 281   (let ((expr (js-compile-to-expression x)))
 282     (make-instance 'one-op :pre-p t :op "~" :value expr)))
 283
 284 ;;; function calls
 285
 286 (defun funcall-form-p (form)
 287   (and (listp form)
 288        (not (op-form-p form))
 289        (not (js-special-form-p form))))
 290
 291 (defun method-call-p (form)
 292   (and (funcall-form-p form)
 293        (symbolp (first form))
 294        (eql (char (symbol-name (first form)) 0) #\.)))
 295
 296 ;;; progn
 297
 298 (define-js-special-form progn (&rest body)
 299   (make-instance 'js-body
 300                  :stmts (mapcar #'js-compile-to-statement body)))
 301
 302 (defmethod expression-precedence ((body js-body))
 303   (if (= (length (b-stmts body)) 1)
 304       (expression-precedence (first (b-stmts body)))
 305       (op-precedence 'comma)))
 306
 307 ;;; function definition
 308 (define-js-special-form lambda (args &rest body)
 309   (make-instance 'js-lambda
 310                  :args (mapcar #'js-compile-to-symbol args)
 311                  :body (make-instance 'js-body
 312                                       :indent "  "
 313                                       :stmts (mapcar #'js-compile-to-statement body))))
 314
 315 (define-js-special-form defun (name args &rest body)
 316   (make-instance 'js-defun
 317                  :name (js-compile-to-symbol name)
 318                  :args (mapcar #'js-compile-to-symbol args)
 319                  :body (make-instance 'js-body
 320                                       :indent "  "
 321                                       :stmts (mapcar #'js-compile-to-statement body))))
 322
 323 ;;; object creation
 324 (define-js-special-form create (&rest args)
 325   (make-instance 'js-object
 326                  :slots (loop for (name val) on args by #'cddr
 327                               collect (let ((name-expr (js-compile-to-expression name)))
 328                                         (assert (or (typep name-expr 'js-variable)
 329                                                     (typep name-expr 'string-literal)
 330                                                     (typep name-expr 'number-literal)))
 331                                         (list name-expr (js-compile-to-expression val))))))
 332
 333
 334 (define-js-special-form slot-value (obj slot)
 335   (make-instance 'js-slot-value :object (js-compile-to-expression obj)
 336                    :slot (js-compile slot)))
 337
 338 ;;; cond
 339 (define-js-special-form cond (&rest clauses)
 340   (make-instance 'js-cond
 341                  :tests (mapcar (lambda (clause) (js-compile-to-expression (car clause)))
 342                                 clauses)
 343                  :bodies (mapcar (lambda (clause) (js-compile-to-body (cons 'progn (cdr clause)) :indent "  "))
 344                                  clauses)))
 345
 346 ;;; if
 347 (define-js-special-form if (test then &optional else)
 348   (make-instance 'js-if :test (js-compile-to-expression test)
 349                  :then (js-compile-to-body then :indent "  ")
 350                  :else (when else
 351                          (js-compile-to-body else :indent "  "))))
 352
 353 (defmethod expression-precedence ((if js-if))
 354   (op-precedence 'if))
 355
 356 ;;; switch
 357 (define-js-special-form switch (value &rest clauses)
 358   (let ((clauses (mapcar #'(lambda (clause)
 359                              (let ((val (first clause))
 360                                    (body (cdr clause)))
 361                                (list (if (eql val 'default)
 362                                          'default
 363                                          (js-compile-to-expression val))
 364                                      (js-compile-to-body (cons 'progn body) :indent "  "))))
 365                          clauses))
 366         (check (js-compile-to-expression value)))
 367     (make-instance 'js-switch :value check
 368                    :clauses clauses)))
 369
 370
 371 (defjsmacro case (value &rest clauses)
 372   (labels ((make-clause (val body more)
 373              (cond ((listp val)
 374                     (append (mapcar #'list (butlast val))
 375                             (make-clause (first (last val)) body more)))
 376                    ((member val '(t otherwise))
 377                     (make-clause 'default body more))
 378                    (more `((,val ,@body break)))
 379                    (t `((,val ,@body))))))
 380     `(switch ,value ,@(mapcon #'(lambda (x)
 381                                   (make-clause (car (first x))
 382                                                (cdr (first x))
 383                                                (rest x)))
 384                               clauses))))
 385
 386 ;;; assignment
 387 (defun assignment-op (op)
 388   (case op
 389     (+ '+=)
 390     (~ '~=)
 391     (\& '\&=)
 392     (\| '\|=)
 393     (- '-=)
 394     (* '*=)
 395     (% '%=)
 396     (>> '>>=)
 397     (^  '^=)
 398     (<< '<<=)
 399     (>>> '>>>=)
 400     (/   '/=)
 401     (t   nil)))
 402
 403 (defun make-js-test (lhs rhs)
 404   (if (and (typep rhs 'op-form)
 405            (member lhs (op-args rhs) :test #'js-equal))
 406       (let ((args-without (remove lhs (op-args rhs)
 407                                   :count 1 :test #'js-equal))
 408             (args-without-first (remove lhs (op-args rhs)
 409                                         :count 1 :end 1
 410                                         :test #'js-equal))
 411             (one (list (make-instance 'number-literal :value 1))))
 412         #+nil
 413         (format t "OPERATOR: ~S, ARGS-WITHOUT: ~S, ARGS-WITHOUT-FIRST ~S~%"
 414                 (operator rhs)
 415                 args-without
 416                 args-without-first)
 417         (cond ((and (js-equal args-without one)
 418                     (eql (operator rhs) '+))
 419                (make-instance 'one-op :pre-p nil :op "++"
 420                               :value lhs))
 421               ((and (js-equal args-without-first one)
 422                     (eql (operator rhs) '-))
 423                (make-instance 'one-op :pre-p nil :op "--"
 424                               :value lhs))
 425               ((and (assignment-op (operator rhs))
 426                     (member (operator rhs)
 427                             '(+ *))
 428                     (js-equal lhs (first (op-args rhs))))
 429                (make-instance 'op-form
 430                               :operator (assignment-op (operator rhs))
 431                               :args (list lhs (make-instance 'op-form
 432                                                              :operator (operator rhs)
 433                                                              :args args-without-first))))
 434               ((and (assignment-op (operator rhs))
 435                     (js-equal (first (op-args rhs)) lhs))
 436                (make-instance 'op-form
 437                               :operator (assignment-op (operator rhs))
 438                               :args (list lhs (make-instance 'op-form
 439                                                              :operator (operator rhs)
 440                                                              :args (cdr (op-args rhs))))))
 441               (t (make-instance 'js-setf :lhs lhs :rhsides (list rhs)))))
 442       (make-instance 'js-setf :lhs lhs :rhsides (list rhs))))
 443
 444 (define-js-special-form setf (&rest args)
 445   (let ((assignments (loop for (lhs rhs) on args by #'cddr
 446                            for rexpr = (js-compile-to-expression rhs)
 447                            for lexpr = (js-compile-to-expression lhs)
 448                            collect (make-js-test lexpr rexpr))))
 449     (if (= (length assignments) 1)
 450         (first assignments)
 451         (make-instance 'js-body :indent "" :stmts assignments))))
 452
 453 (defmethod expression-precedence ((setf js-setf))
 454   (op-precedence '=))
 455
 456 ;;; defvar
 457 (define-js-special-form defvar (name &optional value)
 458   (make-instance 'js-defvar :names (list (js-compile-to-symbol name))
 459                  :value (when value (js-compile-to-expression value))))
 460
 461 ;;; let
 462 (define-js-special-form let (decls &rest body)
 463   (let ((defvars (mapcar #'(lambda (decl)
 464                              (if (atom decl)
 465                                  (make-instance 'js-defvar
 466                                        :names (list (js-compile-to-symbol decl))
 467                                        :value nil)
 468                                  (let ((name (first decl))
 469                                        (value (second decl)))
 470                                    (make-instance 'js-defvar
 471                                                   :names (list (js-compile-to-symbol name))
 472                                                   :value (js-compile-to-expression value)))))
 473                          decls)))
 474     (make-instance 'js-sub-body
 475                    :indent "  "
 476                    :stmts (nconc defvars
 477                                  (mapcar #'js-compile-to-statement body)))))
 478
 479 ;;; iteration
 480 (defun make-for-vars (decls)
 481   (loop for decl in decls
 482         for var = (if (atom decl) decl (first decl))
 483         for init = (if (atom decl) nil (second decl))
 484         collect (make-instance 'js-defvar :names (list (js-compile-to-symbol var))
 485                                :value (js-compile-to-expression init))))
 486
 487 (defun make-for-steps (decls)
 488   (loop for decl in decls
 489         when (= (length decl) 3)
 490         collect (js-compile-to-expression (third decl))))
 491
 492 (define-js-special-form do (decls termination &rest body)
 493   (let ((vars (make-for-vars decls))
 494         (steps (make-for-steps decls))
 495         (check (js-compile-to-expression (list 'not (first termination))))
 496         (body (js-compile-to-body (cons 'progn body) :indent "  ")))
 497     (make-instance 'js-for
 498                    :vars vars
 499                    :steps steps
 500                    :check check
 501                    :body body)))
 502
 503 (defjsmacro dotimes (iter &rest body)
 504   (let ((var (first iter))
 505         (times (second iter)))
 506   `(do ((,var 0 (1+ ,var)))
 507        ((>= ,var ,times))
 508      ,@body)))
 509
 510 (defjsmacro dolist (i-array &rest body)
 511   (let ((var (first i-array))
 512         (array (second i-array))
 513         (arrvar (js-gensym "arr"))
 514         (idx (js-gensym "i")))
 515     `(let ((,arrvar ,array))
 516       (do ((,idx 0 (1+ ,idx)))
 517           ((>= ,idx (slot-value ,arrvar 'length)))
 518         (let ((,var (aref ,arrvar ,idx)))
 519           ,@body)))))
 520
 521 (define-js-special-form doeach (decl &rest body)
 522   (make-instance 'for-each :name (js-compile-to-symbol (first decl))
 523                  :value (js-compile-to-expression (second decl))
 524                  :body (js-compile-to-body (cons 'progn body) :indent "  ")))
 525
 526 (define-js-special-form while (check &rest body)
 527   (make-instance 'js-while
 528                  :check (js-compile-to-expression check)
 529                  :body (js-compile-to-body (cons 'progn body) :indent "  ")))
 530
 531 ;;; with
 532
 533 ;;; try-catch
 534 (define-js-special-form try (body &rest clauses)
 535   (let ((body (js-compile-to-body body :indent "  "))
 536         (catch (cdr (assoc :catch clauses)))
 537         (finally (cdr (assoc :finally clauses))))
 538     (assert (not (cdar catch)) nil "Sorry, currently only simple catch forms are supported.")
 539     (make-instance 'js-try
 540                    :body body
 541                    :catch (when catch (list (js-compile-to-symbol (caar catch))
 542                                             (js-compile-to-body (cons 'progn (cdr catch))
 543                                                                 :indent "  ")))
 544                    :finally (when finally (js-compile-to-body (cons 'progn finally)
 545                                                               :indent "  ")))))
 546 ;;; regex
 547 (define-js-special-form regex (regex)
 548   (make-instance 'regex :value (string regex)))
 549
 550 ;;; TODO instanceof
 551 (define-js-special-form instanceof (value type)
 552   (make-instance 'js-instanceof
 553                  :value (js-compile-to-expression value)
 554                  :type (js-compile-to-expression type)))
 555
 556 ;;; single operations
 557 (defmacro define-parse-js-single-op (name &optional (superclass 'expression))
 558   (let ((js-name (intern (concatenate 'string "JS-" (symbol-name name)) #.*package*)))
 559     `(define-js-special-form ,name (value)
 560        (make-instance ',js-name :value (js-compile-to-expression value)))
 561     ))
 562
 563 (define-parse-js-single-op return statement)
 564 (define-parse-js-single-op throw statement)
 565 (define-parse-js-single-op delete)
 566 (define-parse-js-single-op void)
 567 (define-parse-js-single-op typeof)
 568 (define-parse-js-single-op new)
 569
 570 ;;; conditional compilation
 571 (define-js-special-form cc-if (test &rest body)
 572   (make-instance 'cc-if :test test
 573                  :body (mapcar #'js-compile body)))
 574
 575 ;;; standard macros
 576 (defjsmacro with-slots (slots object &rest body)
 577   `(symbol-macrolet ,(mapcar #'(lambda (slot)
 578                                  `(,slot '(slot-value ,object ',slot)))
 579                              slots)
 580     ,@body))
 581
 582 (defjsmacro when (test &rest body)
 583   `(if ,test (progn ,@body)))
 584
 585 (defjsmacro unless (test &rest body)
 586   `(if (not ,test) (progn ,@body)))
 587
 588 (defjsmacro 1- (form)
 589   `(- ,form 1))
 590
 591 (defjsmacro 1+ (form)
 592   `(+ ,form 1))
 593
 594 ;;; macros
 595 (defmacro with-temp-macro-environment ((var) &body body)
 596   `(let* ((,var (make-macro-env-dictionary))
 597           (*js-macro-env* (cons ,var *js-macro-env*)))
 598     ,@body))
 599
 600 (define-js-special-form macrolet (macros &body body)
 601   (with-temp-macro-environment (macro-env-dict)
 602     (dolist (macro macros)
 603       (destructuring-bind (name arglist &body body)
 604           macro
 605         (setf (get-macro-spec name macro-env-dict)
 606               (cons nil (let ((args (gensym "ps-macrolet-args-")))
 607                           (compile nil `(lambda (&rest ,args)
 608                                          (destructuring-bind ,arglist
 609                                              ,args
 610                                            ,@body))))))))
 611     (js-compile `(progn ,@body))))
 612
 613 (define-js-special-form symbol-macrolet (symbol-macros &body body)
 614   (with-temp-macro-environment (macro-env-dict)
 615     (dolist (macro symbol-macros)
 616       (destructuring-bind (name &body expansion)
 617           macro
 618         (setf (get-macro-spec name macro-env-dict)
 619               (cons t (compile nil `(lambda () ,@expansion))))))
 620     (js-compile `(progn ,@body))))
 621
 622 (defjsmacro defmacro (name args &body body)
 623   `(lisp (defjsmacro ,name ,args ,@body) nil))
 624
 625 (defjsmacro lisp (&body forms)
 626   "Evaluates the given forms in Common Lisp at ParenScript
 627 macro-expansion time. The value of the last form is treated as a
 628 ParenScript expression and is inserted into the generated Javascript
 629 (use nil for no-op)."
 630   (eval (cons 'progn forms)))
 631
 632 ;;; Math library
 633 (defjsmacro floor (expr)
 634   `(*Math.floor ,expr))
 635
 636 (defjsmacro random ()
 637   `(*Math.random))
 638
 639 (defjsmacro evenp (num)
 640   `(= (% ,num 2) 0))
 641
 642 (defjsmacro oddp (num)
 643   `(= (% ,num 2) 1))
 644
 645 ;;; helper macros
 646 (define-js-special-form js (&rest body)
 647   (make-instance 'string-literal
 648                  :value (string-join (js-to-statement-strings
 649                                       (js-compile (cons 'progn body)) 0) " ")))
 650
 651 (define-js-special-form js-inline (&rest body)
 652   (make-instance 'string-literal
 653                  :value (concatenate
 654                          'string
 655                          "javascript:"
 656                          (string-join (js-to-statement-strings
 657                                        (js-compile (cons 'progn body)) 0) " "))))
 658
 659 ;;;; compiler interface ;;;;
 660 (defun js-compile (form)
 661   (setf form (js-expand-form form))
 662   (cond ((stringp form)
 663          (make-instance 'string-literal :value form))
 664         ((characterp form)
 665          (make-instance 'string-literal :value (string form)))
 666         ((numberp form)
 667          (make-instance 'number-literal :value form))
 668         ((symbolp form)
 669          (let ((c-macro (js-get-special-form form)))
 670            (if c-macro
 671                (funcall c-macro)
 672                (make-instance 'js-variable :value form))))
 673         ((and (consp form)
 674               (eql (first form) 'quote))
 675          (make-instance 'js-quote :value (second form)))
 676         ((consp form)
 677          (js-compile-list form))
 678         (t (error "Unknown atomar expression ~S" form))))
 679
 680 (defun js-compile-list (form)
 681   (let* ((name (car form))
 682          (args (cdr form))
 683          (js-form (js-get-special-form name)))
 684     (cond (js-form
 685            (apply js-form args))
 686
 687           ((op-form-p form)
 688            (make-instance 'op-form
 689                           :operator (js-convert-op-name (js-compile-to-symbol (first form)))
 690                           :args (mapcar #'js-compile-to-expression (rest form))))
 691
 692           ((method-call-p form)
 693            (make-instance 'method-call
 694                           :method (js-compile-to-symbol (first form))
 695                           :object (js-compile-to-expression (second form))
 696                           :args (mapcar #'js-compile-to-expression (cddr form))))
 697
 698           ((funcall-form-p form)
 699            (make-instance 'function-call
 700                           :function (js-compile-to-expression (first form))
 701                           :args (mapcar #'js-compile-to-expression (rest form))))
 702
 703           (t (error "Unknown form ~S" form)))))
 704
 705 (defun js-compile-to-expression (form)
 706   (let ((res (js-compile form)))
 707     (assert (typep res 'expression))
 708     res))
 709
 710 (defun js-compile-to-symbol (form)
 711   (let ((res (js-compile form)))
 712     (when (typep res 'js-variable )
 713       (setf res (value res)))
 714     (assert (symbolp res))
 715     res))
 716
 717 (defun js-compile-to-statement (form)
 718   (let ((res (js-compile form)))
 719     (assert (typep res 'statement))
 720     res))
 721
 722 (defun js-compile-to-body (form &key (indent ""))
 723   (let ((res (js-compile-to-statement form)))
 724     (if (typep res 'js-body)
 725         (progn (setf (b-indent res) indent)
 726                res)
 727         (make-instance 'js-body
 728                        :indent indent
 729                        :stmts (list res)))))
 730
 731 (defmacro js (&rest body)
 732   `(js* '(progn ,@body)))
 733
 734 (defmacro js* (&rest body)
 735   "Return the javascript string representing BODY.
 736
 737 Body is evaluated."
 738   `(string-join
 739     (js-to-statement-strings (js-compile (list 'progn ,@body)) 0)
 740     (string #\Newline)))
 741
 742 (defun js-to-string (expr)
 743   (string-join
 744    (js-to-statement-strings (js-compile expr) 0)
 745    (string #\Newline)))
 746
 747 (defun js-to-line (expr)
 748   (string-join
 749    (js-to-statement-strings (js-compile expr) 0) " "))
 750
 751 (defmacro js-file (&rest body)
 752   `(html
 753     (:princ
 754      (js ,@body))))
 755
 756 (defmacro js-script (&rest body)
 757   `((:script :type "text/javascript")
 758     (:princ (format nil "~%// <![CDATA[~%"))
 759     (:princ (js ,@body))
 760     (:princ (format nil "~%// ]]>~%"))))
 761
 762 (defmacro js-inline (&rest body)
 763   `(js-inline* '(progn ,@body)))
 764
 765 (defmacro js-inline* (&rest body)
 766   "Just like JS-INLINE except that BODY is evaluated before being
 767 converted to javascript."
 768   `(concatenate 'string "javascript:"
 769     (string-join (js-to-statement-strings (js-compile (list 'progn ,@body)) 0) " ")))
 770
 771