src/macrology.lisp

   1 (in-package :parenscript)
   2
   3 ;;;; The macrology of the basic Parenscript language.  Special forms and macros in the
   4 ;;;; Parenscript language.
   5
   6 ;;; parenscript gensyms
   7 (defvar *gen-script-name-counter* 0)
   8
   9 (defun gen-script-name-string (&key (prefix "_ps_"))
  10   "Generates a unique valid javascript identifier ()"
  11   (concatenate 'string
  12                prefix (princ-to-string (incf *gen-script-name-counter*))))
  13
  14 (defun gen-script-name (&key (prefix "_ps_"))
  15   "Generate a new javascript identifier."
  16   (intern (gen-script-name-string :prefix prefix)
  17           (find-package :js)))
  18
  19 (defmacro with-unique-js-names (symbols &body body)
  20   "Evaluate BODY with the variables on SYMBOLS bound to new javascript identifiers.
  21
  22 Each element of SYMBOLS is either a symbol or a list of (symbol
  23 prefix)."
  24   `(let* ,(mapcar (lambda (symbol)
  25                     (destructuring-bind (symbol &optional prefix)
  26                         (if (consp symbol)
  27                             symbol
  28                             (list symbol))
  29                       (if prefix
  30                           `(,symbol (gen-script-name :prefix ,prefix))
  31                           `(,symbol (gen-script-name)))))
  32                   symbols)
  33      ,@body))
  34
  35 (defvar *var-counter* 0)
  36
  37 (defun script-gensym (&optional (name "js"))
  38   (intern (format nil "tmp-~A-~A" name (incf *var-counter*)) #.*package*))
  39
  40 ;;; literals
  41 (defmacro defscriptliteral (name string)
  42   "Define a Javascript literal that will expand to STRING."
  43   `(define-script-special-form ,name () (make-instance 'expression :value ,string)))
  44
  45 (defscriptliteral this      "this")
  46 (defscriptliteral t         "true")
  47 (defscriptliteral nil       "null")
  48 (defscriptliteral false     "false")
  49 (defscriptliteral undefined "undefined")
  50
  51 (defmacro defscriptkeyword (name string)
  52   "Define a Javascript keyword that will expand to STRING."
  53   `(define-script-special-form ,name () (make-instance 'statement :value ,string)))
  54
  55 (defscriptkeyword break    "break")
  56 (defscriptkeyword continue "continue")
  57
  58 ;;; array literals
  59 (define-script-special-form array (&rest values)
  60   (make-instance 'array-literal
  61                  :values (mapcar #'compile-to-expression values)))
  62
  63 (defscriptmacro list (&rest values)
  64   `(array ,@values))
  65
  66 (define-script-special-form aref (array &rest coords)
  67   (make-instance 'script-aref
  68                  :array (compile-to-expression array)
  69                  :index (mapcar #'compile-to-expression coords)))
  70
  71
  72 (defscriptmacro make-array (&rest inits)
  73   `(new (*array ,@inits)))
  74
  75 ;;; object literals (maps and hash-tables)
  76 (define-script-special-form {} (&rest values)
  77   (make-instance 'object-literal
  78                  :values (loop
  79                             for (key value) on values by #'cddr
  80                             collect (cons key (compile-to-expression value)))))
  81
  82 ;;; operators
  83 (define-script-special-form ++ (x)
  84   (make-instance 'one-op :pre-p nil :op "++"
  85                  :value (compile-to-expression x)))
  86
  87 (define-script-special-form -- (x)
  88   (make-instance 'one-op :pre-p nil :op "--"
  89                  :value (compile-to-expression x)))
  90
  91 (define-script-special-form incf (x &optional (delta 1))
  92   (if (eql delta 1)
  93       (make-instance 'one-op :pre-p t :op "++"
  94                      :value (compile-to-expression x))
  95       (make-instance 'op-form
  96                      :operator '+=
  97                      :args (mapcar #'compile-to-expression
  98                                    (list x delta )))))
  99
 100 (define-script-special-form decf (x &optional (delta 1))
 101   (if (eql delta 1)
 102       (make-instance 'one-op :pre-p t :op "--"
 103                      :value (compile-to-expression x))
 104       (make-instance 'op-form
 105                      :operator '-=
 106                      :args (mapcar #'compile-to-expression
 107                                    (list x delta )))))
 108
 109 (define-script-special-form - (first &rest rest)
 110   (if (null rest)
 111       (make-instance 'one-op
 112                      :pre-p t
 113                      :op "-"
 114                      :value (compile-to-expression first))
 115       (make-instance 'op-form
 116                      :operator '-
 117                      :args (mapcar #'compile-to-expression
 118                                    (cons first rest)))))
 119
 120 (define-script-special-form not (x)
 121   (let ((value (compile-to-expression x)))
 122     (if (and (typep value 'op-form)
 123              (= (length (op-args value)) 2))
 124         (let ((new-op (case (operator value)
 125                         (== '!=)
 126                         (< '>=)
 127                         (> '<=)
 128                         (<= '>)
 129                         (>= '<)
 130                         (!= '==)
 131                         (=== '!==)
 132                         (!== '===)
 133                         (t nil))))
 134           (if new-op
 135               (make-instance 'op-form :operator new-op
 136                              :args (op-args value))
 137               (make-instance 'one-op :pre-p t :op "!"
 138                             :value value)))
 139         (make-instance 'one-op :pre-p t :op "!"
 140                        :value value))))
 141
 142 (define-script-special-form ~ (x)
 143   (let ((expr (compile-to-expression x)))
 144     (make-instance 'one-op :pre-p t :op "~" :value expr)))
 145
 146 ;;; progn
 147 (define-script-special-form progn (&rest body)
 148   (make-instance 'script-body
 149                  :statements (mapcar #'compile-to-statement body)))
 150
 151 (defmethod expression-precedence ((body script-body))
 152   (if (= (length (b-statements body)) 1)
 153       (expression-precedence (first (b-statements body)))
 154       (op-precedence 'comma)))
 155
 156 ;;; function definition
 157 (define-script-special-form lambda (args &rest body)
 158   (make-instance 'script-lambda
 159                  :args (mapcar #'compile-to-symbol args)
 160                  :body (make-instance 'script-body
 161                                       :indent "  "
 162                                       :statements (mapcar #'compile-to-statement body))))
 163
 164 (define-script-special-form defun (name args &rest body)
 165   (make-instance 'script-defun
 166                  :name (compile-to-symbol name)
 167                  :args (mapcar #'compile-to-symbol args)
 168                  :body (make-instance 'script-body
 169                                       :indent "  "
 170                                       :statements (mapcar #'compile-to-statement body))))
 171
 172 ;;; object creation
 173 (define-script-special-form create (&rest args)
 174   (make-instance 'script-object
 175                  :slots (loop for (name val) on args by #'cddr
 176                               collect (let ((name-expr (compile-to-expression name)))
 177                                         (assert (or (typep name-expr 'script-variable)
 178                                                     (typep name-expr 'string-literal)
 179                                                     (typep name-expr 'number-literal)))
 180                                         (list name-expr (compile-to-expression val))))))
 181
 182
 183 (define-script-special-form slot-value (obj slot)
 184   (make-instance 'script-slot-value :object (compile-to-expression obj)
 185                    :slot (compile-script-form slot)))
 186
 187 ;;; cond
 188 (define-script-special-form cond (&rest clauses)
 189   (make-instance 'script-cond
 190                  :tests (mapcar (lambda (clause) (compile-to-expression (car clause)))
 191                                 clauses)
 192                  :bodies (mapcar (lambda (clause) (compile-to-body (cons 'progn (cdr clause)) :indent "  "))
 193                                  clauses)))
 194
 195 ;;; if
 196 (define-script-special-form if (test then &optional else)
 197   (make-instance 'script-if :test (compile-to-expression test)
 198                  :then (compile-to-body then :indent "  ")
 199                  :else (when else
 200                          (compile-to-body else :indent "  "))))
 201
 202 (defmethod expression-precedence ((if script-if))
 203   (op-precedence 'if))
 204
 205 ;;; switch
 206 (define-script-special-form switch (value &rest clauses)
 207   (let ((clauses (mapcar #'(lambda (clause)
 208                              (let ((val (first clause))
 209                                    (body (cdr clause)))
 210                                (list (if (eql val 'default)
 211                                          'default
 212                                          (compile-to-expression val))
 213                                      (compile-to-body (cons 'progn body) :indent "  "))))
 214                          clauses))
 215         (check (compile-to-expression value)))
 216     (make-instance 'script-switch :value check
 217                    :clauses clauses)))
 218
 219
 220 (defscriptmacro case (value &rest clauses)
 221   (labels ((make-clause (val body more)
 222              (cond ((listp val)
 223                     (append (mapcar #'list (butlast val))
 224                             (make-clause (first (last val)) body more)))
 225                    ((member val '(t otherwise))
 226                     (make-clause 'default body more))
 227                    (more `((,val ,@body break)))
 228                    (t `((,val ,@body))))))
 229     `(switch ,value ,@(mapcon #'(lambda (x)
 230                                   (make-clause (car (first x))
 231                                                (cdr (first x))
 232                                                (rest x)))
 233                               clauses))))
 234
 235 ;;; assignment
 236 (defun assignment-op (op)
 237   (case op
 238     (+ '+=)
 239     (~ '~=)
 240     (\& '\&=)
 241     (\| '\|=)
 242     (- '-=)
 243     (* '*=)
 244     (% '%=)
 245     (>> '>>=)
 246     (^  '^=)
 247     (<< '<<=)
 248     (>>> '>>>=)
 249     (/   '/=)
 250     (t   nil)))
 251
 252 (defun make-js-test (lhs rhs)
 253   (if (and (typep rhs 'op-form)
 254            (member lhs (op-args rhs) :test #'js-equal))
 255       (let ((args-without (remove lhs (op-args rhs)
 256                                   :count 1 :test #'js-equal))
 257             (args-without-first (remove lhs (op-args rhs)
 258                                         :count 1 :end 1
 259                                         :test #'js-equal))
 260             (one (list (make-instance 'number-literal :value 1))))
 261         #+nil
 262         (format t "OPERATOR: ~S, ARGS-WITHOUT: ~S, ARGS-WITHOUT-FIRST ~S~%"
 263                 (operator rhs)
 264                 args-without
 265                 args-without-first)
 266         (cond ((and (js-equal args-without one)
 267                     (eql (operator rhs) '+))
 268                (make-instance 'one-op :pre-p nil :op "++"
 269                               :value lhs))
 270               ((and (js-equal args-without-first one)
 271                     (eql (operator rhs) '-))
 272                (make-instance 'one-op :pre-p nil :op "--"
 273                               :value lhs))
 274               ((and (assignment-op (operator rhs))
 275                     (member (operator rhs)
 276                             '(+ *))
 277                     (js-equal lhs (first (op-args rhs))))
 278                (make-instance 'op-form
 279                               :operator (assignment-op (operator rhs))
 280                               :args (list lhs (make-instance 'op-form
 281                                                              :operator (operator rhs)
 282                                                              :args args-without-first))))
 283               ((and (assignment-op (operator rhs))
 284                     (js-equal (first (op-args rhs)) lhs))
 285                (make-instance 'op-form
 286                               :operator (assignment-op (operator rhs))
 287                               :args (list lhs (make-instance 'op-form
 288                                                              :operator (operator rhs)
 289                                                              :args (cdr (op-args rhs))))))
 290               (t (make-instance 'script-setf :lhs lhs :rhsides (list rhs)))))
 291       (make-instance 'script-setf :lhs lhs :rhsides (list rhs))))
 292
 293 (define-script-special-form setf (&rest args)
 294   (let ((assignments (loop for (lhs rhs) on args by #'cddr
 295                            for rexpr = (compile-to-expression rhs)
 296                            for lexpr = (compile-to-expression lhs)
 297                            collect (make-js-test lexpr rexpr))))
 298     (if (= (length assignments) 1)
 299         (first assignments)
 300         (make-instance 'script-body :indent "" :statements assignments))))
 301
 302 (defmethod expression-precedence ((setf script-setf))
 303   (op-precedence '=))
 304
 305 ;;; defvar
 306 (define-script-special-form defvar (name &optional value)
 307   (make-instance 'script-defvar :names (list (compile-to-symbol name))
 308                  :value (when value (compile-to-expression value))))
 309
 310 ;;; let
 311 (define-script-special-form let (decls &rest body)
 312   (let ((defvars (mapcar #'(lambda (decl)
 313                              (if (atom decl)
 314                                  (make-instance 'script-defvar
 315                                        :names (list (compile-to-symbol decl))
 316                                        :value nil)
 317                                  (let ((name (first decl))
 318                                        (value (second decl)))
 319                                    (make-instance 'script-defvar
 320                                                   :names (list (compile-to-symbol name))
 321                                                   :value (compile-to-expression value)))))
 322                          decls)))
 323     (make-instance 'script-sub-body
 324                    :indent "  "
 325                    :statements (nconc defvars
 326                                  (mapcar #'compile-to-statement body)))))
 327
 328 ;;; iteration
 329 (defun make-for-vars (decls)
 330   (loop for decl in decls
 331         for var = (if (atom decl) decl (first decl))
 332         for init = (if (atom decl) nil (second decl))
 333         collect (make-instance 'script-defvar :names (list (compile-to-symbol var))
 334                                :value (compile-to-expression init))))
 335
 336 (defun make-for-steps (decls)
 337   (loop for decl in decls
 338         when (= (length decl) 3)
 339         collect (compile-to-expression (third decl))))
 340
 341 (define-script-special-form do (decls termination &rest body)
 342   (let ((vars (make-for-vars decls))
 343         (steps (make-for-steps decls))
 344         (check (compile-to-expression (list 'not (first termination))))
 345         (body (compile-to-body (cons 'progn body) :indent "  ")))
 346     (make-instance 'script-for
 347                    :vars vars
 348                    :steps steps
 349                    :check check
 350                    :body body)))
 351
 352 (defscriptmacro dotimes (iter &rest body)
 353   (let ((var (first iter))
 354         (times (second iter)))
 355   `(do ((,var 0 (1+ ,var)))
 356        ((>= ,var ,times))
 357      ,@body)))
 358
 359 (defscriptmacro dolist (i-array &rest body)
 360   (let ((var (first i-array))
 361         (array (second i-array))
 362         (arrvar (script-gensym "arr"))
 363         (idx (script-gensym "i")))
 364     `(let ((,arrvar ,array))
 365       (do ((,idx 0 (1+ ,idx)))
 366           ((>= ,idx (slot-value ,arrvar 'length)))
 367         (let ((,var (aref ,arrvar ,idx)))
 368           ,@body)))))
 369
 370 (define-script-special-form doeach (decl &rest body)
 371   (make-instance 'for-each :name (compile-to-symbol (first decl))
 372                  :value (compile-to-expression (second decl))
 373                  :body (compile-to-body (cons 'progn body) :indent "  ")))
 374
 375 (define-script-special-form while (check &rest body)
 376   (make-instance 'script-while
 377                  :check (compile-to-expression check)
 378                  :body (compile-to-body (cons 'progn body) :indent "  ")))
 379
 380 ;;; with
 381 (define-script-special-form with (statement &rest body)
 382   (make-instance 'script-with
 383                  :obj (compile-to-expression statement)
 384                  :body (compile-to-body (cons 'progn body) :indent "  ")))
 385
 386
 387 ;;; try-catch
 388 (define-script-special-form try (body &rest clauses)
 389   (let ((body (compile-to-body body :indent "  "))
 390         (catch (cdr (assoc :catch clauses)))
 391         (finally (cdr (assoc :finally clauses))))
 392     (assert (not (cdar catch)) nil "Sorry, currently only simple catch forms are supported.")
 393     (make-instance 'script-try
 394                    :body body
 395                    :catch (when catch (list (compile-to-symbol (caar catch))
 396                                             (compile-to-body (cons 'progn (cdr catch))
 397                                                                 :indent "  ")))
 398                    :finally (when finally (compile-to-body (cons 'progn finally)
 399                                                               :indent "  ")))))
 400 ;;; regex
 401 (define-script-special-form regex (regex)
 402   (make-instance 'regex :value (string regex)))
 403
 404 ;;; TODO instanceof
 405 (define-script-special-form instanceof (value type)
 406   (make-instance 'script-instanceof
 407                  :value (compile-to-expression value)
 408                  :type (compile-to-expression type)))
 409
 410 ;;; eval-when
 411 (define-script-special-form eval-when (&rest args)
 412   "(eval-when form-language? (situation*) form*)
 413
 414 The given forms are evaluated only during the given SITUATION in the specified
 415 FORM-LANGUAGE (either :lisp or :parenscript, def, defaulting to :lisp during
 416 -toplevel and :parenscript during :execute). The accepted SITUATIONS are :execute,
 417 :scan-toplevel. :scan-toplevel is the phase of compilation when function definitions
 418 and the like are being added to the compilation environment. :execute is the phase when
 419 the code is being evaluated by a Javascript engine."
 420   (multiple-value-bind (body-language situations subforms)
 421       (process-eval-when-args args)
 422     (format t "~A~%~A~%"
 423            (and (compiler-in-situation-p *compilation-environment* :compile-toplevel)
 424                 (find :compile-toplevel situations))
 425            (compiler-in-situation-p *compilation-environment*  :execute)
 426             (find :execute situations))
 427     (cond
 428       ((and (compiler-in-situation-p *compilation-environment* :compile-toplevel)
 429             (find :compile-toplevel situations))
 430        (error "Should never be processing eval-when :COMPILE-TOPLEVEL forms from here."))
 431
 432       ((and (compiler-in-situation-p *compilation-environment*  :execute)
 433             (find :execute situations))
 434        (when (eql body-language :parenscript)
 435          (let ((form `(progn ,@subforms)))
 436            (format t "Form: ~A~%" form)
 437            (compile-to-statement form)))))))
 438
 439 ;;; script packages
 440 (define-script-special-form blank-statement ()
 441   (make-instance 'blank-statement))
 442
 443 (defscriptmacro defpackage (name &rest options)
 444   "Defines a Parenscript package."
 445   (labels ((opt-name (opt) (if (listp opt) (car opt) opt)))
 446   (let ((nicknames nil) (lisp-package nil) (secondary-lisp-packages nil)
 447         (exports nil) (used-packages nil) (documentation nil))
 448     (dolist (opt options)
 449       (case (opt-name opt)
 450           (:nicknames (setf nicknames (rest opt)))
 451           (:secondary-lisp-packages secondary-lisp-packages t)
 452           (:export (setf exports (rest opt)))
 453           (:use (setf used-packages (rest opt)))
 454           (:documentation (setf documentation (second opt)))))
 455     (create-script-package
 456      *compilation-environment*
 457      :name name
 458      :nicknames nicknames
 459      :secondary-lisp-packages secondary-lisp-packages
 460      :used-packages used-packages
 461      :lisp-package lisp-package
 462      :exports exports
 463      :documentation documentation)))
 464   `(progn))
 465
 466 (defscriptmacro in-package (package-designator)
 467   "Changes the current script package in the parenscript compilation environment.  This mostly
 468 affects the reader and how it interns non-prefixed symbols"
 469   (setf (comp-env-current-package
 470          *compilation-environment*)
 471         (comp-env-find-package *compilation-environment* package-designator))
 472   `(progn))
 473
 474 ;;; single operations
 475 (defmacro define-parse-script-single-op (name &optional (superclass 'expression))
 476   (let ((script-name (intern (concatenate 'string "SCRIPT-" (symbol-name name)) #.*package*)))
 477     `(define-script-special-form ,name (value)
 478        (make-instance ',script-name :value (compile-to-expression value)))
 479     ))
 480
 481 (define-parse-script-single-op return statement)
 482 (define-parse-script-single-op throw statement)
 483 (define-parse-script-single-op delete)
 484 (define-parse-script-single-op void)
 485 (define-parse-script-single-op typeof)
 486 (define-parse-script-single-op new)
 487
 488 ;;; conditional compilation
 489 (define-script-special-form cc-if (test &rest body)
 490   (make-instance 'cc-if :test test
 491                  :body (mapcar #'compile-script-form body)))
 492
 493 ;;; standard macros
 494 (defscriptmacro with-slots (slots object &rest body)
 495   `(symbol-macrolet ,(mapcar #'(lambda (slot)
 496                                  `(,slot '(slot-value ,object ',slot)))
 497                              slots)
 498     ,@body))
 499
 500 (defscriptmacro when (test &rest body)
 501   `(if ,test (progn ,@body)))
 502
 503 (defscriptmacro unless (test &rest body)
 504   `(if (not ,test) (progn ,@body)))
 505
 506 (defscriptmacro 1- (form)
 507   `(- ,form 1))
 508
 509 (defscriptmacro 1+ (form)
 510   `(+ ,form 1))
 511
 512 ;;; macros
 513 (defmacro with-temp-macro-environment ((var) &body body)
 514   `(let* ((,var (make-macro-env-dictionary))
 515           (*script-macro-env* (cons ,var *script-macro-env*)))
 516     ,@body))
 517
 518 (define-script-special-form macrolet (macros &body body)
 519   (with-temp-macro-environment (macro-env-dict)
 520     (dolist (macro macros)
 521       (destructuring-bind (name arglist &body body)
 522           macro
 523         (setf (get-macro-spec name macro-env-dict)
 524               (cons nil (let ((args (gensym "ps-macrolet-args-")))
 525                           (compile nil `(lambda (&rest ,args)
 526                                          (destructuring-bind ,arglist
 527                                              ,args
 528                                            ,@body))))))))
 529     (compile-script-form `(progn ,@body))))
 530
 531 (define-script-special-form symbol-macrolet (symbol-macros &body body)
 532   (with-temp-macro-environment (macro-env-dict)
 533     (dolist (macro symbol-macros)
 534       (destructuring-bind (name &body expansion)
 535           macro
 536         (setf (get-macro-spec name macro-env-dict)
 537               (cons t (compile nil `(lambda () ,@expansion))))))
 538     (compile-script-form `(progn ,@body))))
 539
 540 (defscriptmacro defmacro (name args &body body)
 541   `(lisp (defscriptmacro ,name ,args ,@body) nil))
 542
 543 (defscriptmacro lisp (&body forms)
 544   "Evaluates the given forms in Common Lisp at ParenScript
 545 macro-expansion time. The value of the last form is treated as a
 546 ParenScript expression and is inserted into the generated Javascript
 547 (use nil for no-op)."
 548   (eval (cons 'progn forms)))
 549
 550
 551 (defscriptmacro rebind (variables expression)
 552   "Creates a new js lexical environment and copies the given
 553   variable(s) there.  Executes the body in the new environment. This
 554   has the same effect as a new (let () ...) form in lisp but works on
 555   the js side for js closures."
 556   (unless (listp variables)
 557     (setf variables (list variables)))
 558   `((lambda ()
 559       (let ((new-context (new *object)))
 560         ,@(loop for variable in variables
 561                 do (setf variable (symbol-to-js variable))
 562                 collect `(setf (slot-value new-context ,variable) (slot-value this ,variable)))
 563         (with new-context
 564               (return ,expression))))))
 565
 566 ;;; Math library
 567 (defscriptmacro floor (expr)
 568   `(*Math.floor ,expr))
 569
 570 (defscriptmacro random ()
 571   `(*Math.random))
 572
 573 (defscriptmacro evenp (num)
 574   `(= (% ,num 2) 0))
 575
 576 (defscriptmacro oddp (num)
 577   `(= (% ,num 2) 1))
 578
 579 ;;; helper macros
 580 (define-script-special-form js (&rest body)
 581   (make-instance 'string-literal
 582                  :value (string-join (js-to-statement-strings
 583                                       (compile-script-form (cons 'progn body)) 0) " ")))
 584
 585 (define-script-special-form script-inline (&rest body)
 586   (make-instance 'string-literal
 587                  :value (concatenate
 588                          'string
 589                          "javascript:"
 590                          (string-join (js-to-statement-strings
 591                                        (compile-script-form (cons 'progn body)) 0) " "))))
 592 (defscriptmacro js-inline (&rest body)
 593   `(script-inline ,@body))
 594
 595 ;;; dual lisp/parenscript macro balderdash
 596 ;;; TODO: should probably move elsewhere ;;;
 597 (defmacro defmacro/js (name args &body body)
 598   "Define a Lisp macro and import it into the ParenScript macro environment."
 599   `(progn (defmacro ,name ,args ,@body)
 600           (js:import-macros-from-lisp ',name)))
 601
 602 (defmacro defmacro+js (name args &body body)
 603   "Define a Lisp macro and a ParenScript macro in their respective
 604 macro environments. This function should be used when you want to use
 605 the same macro in both Lisp and ParenScript, but the 'macroexpand' of
 606 that macro in Lisp makes the Lisp macro unsuitable to be imported into
 607 the ParenScript macro environment."
 608   `(progn (defmacro ,name ,args ,@body)
 609     (defscriptmacro ,name ,args ,@body)))
 610
 611 (defun import-macros-from-lisp (&rest names)
 612   "Import the named Lisp macros into the ParenScript macro environment."
 613   (dolist (name names)
 614     (let ((name name))
 615       (undefine-js-special-form name)
 616       (setf (get-macro-spec name *script-macro-toplevel*)
 617             (cons nil (lambda (&rest args)
 618                         (macroexpand `(,name ,@args))))))))
 619
 620 (defmacro js-file (&rest body)
 621   `(html
 622     (:princ
 623      (js ,@body))))
 624
 625 (defmacro js-script (&rest body)
 626   `((:script :type "text/javascript")
 627     (:princ (format nil "~%// <![CDATA[~%"))
 628     (:princ (js ,@body))
 629     (:princ (format nil "~%// ]]>~%"))))
 630
 631 (defmacro js-inline (&rest body)
 632   `(js-inline* '(progn ,@body)))
 633
 634 (defmacro js-inline* (&rest body)
 635   "Just like JS-INLINE except that BODY is evaluated before being
 636 converted to javascript."
 637   `(concatenate 'string "javascript:"
 638     (string-join (js-to-statement-strings (compile-script-form (list 'progn ,@body)) 0) " ")))