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 ;;; script packages
 411 (define-script-special-form blank-statement ()
 412   (make-instance 'blank-statement))
 413
 414 (defscriptmacro defpackage (name &rest options)
 415   "Defines a Parenscript package."
 416   (labels ((opt-name (opt) (if (listp opt) (car opt) opt)))
 417   (let ((nicknames nil) (lisp-package nil) (secondary-lisp-packages nil)
 418         (exports nil) (used-packages nil) (documentation nil))
 419     (dolist (opt options)
 420       (case (opt-name opt)
 421           (:nicknames (setf nicknames (rest opt)))
 422           (:secondary-lisp-packages secondary-lisp-packages t)
 423           (:export (setf exports (rest opt)))
 424           (:use (setf used-packages (rest opt)))
 425           (:documentation (setf documentation (second opt)))))
 426     (create-script-package
 427      *compilation-environment*
 428      :name name
 429      :nicknames nicknames
 430      :secondary-lisp-packages secondary-lisp-packages
 431      :used-packages used-packages
 432      :lisp-package lisp-package
 433      :exports exports
 434      :documentation documentation)))
 435   `(progn))
 436
 437 (defscriptmacro in-package (package-designator)
 438   "Changes the current script package in the parenscript compilation environment.  This mostly
 439 affects the reader and how it interns non-prefixed symbols"
 440   (setf (comp-env-current-package
 441          *compilation-environment*)
 442         (comp-env-find-package *compilation-environment* package-designator))
 443   `(progn))
 444
 445 ;;; single operations
 446 (defmacro define-parse-script-single-op (name &optional (superclass 'expression))
 447   (let ((script-name (intern (concatenate 'string "SCRIPT-" (symbol-name name)) #.*package*)))
 448     `(define-script-special-form ,name (value)
 449        (make-instance ',script-name :value (compile-to-expression value)))
 450     ))
 451
 452 (define-parse-script-single-op return statement)
 453 (define-parse-script-single-op throw statement)
 454 (define-parse-script-single-op delete)
 455 (define-parse-script-single-op void)
 456 (define-parse-script-single-op typeof)
 457 (define-parse-script-single-op new)
 458
 459 ;;; conditional compilation
 460 (define-script-special-form cc-if (test &rest body)
 461   (make-instance 'cc-if :test test
 462                  :body (mapcar #'compile-script-form body)))
 463
 464 ;;; standard macros
 465 (defscriptmacro with-slots (slots object &rest body)
 466   `(symbol-macrolet ,(mapcar #'(lambda (slot)
 467                                  `(,slot '(slot-value ,object ',slot)))
 468                              slots)
 469     ,@body))
 470
 471 (defscriptmacro when (test &rest body)
 472   `(if ,test (progn ,@body)))
 473
 474 (defscriptmacro unless (test &rest body)
 475   `(if (not ,test) (progn ,@body)))
 476
 477 (defscriptmacro 1- (form)
 478   `(- ,form 1))
 479
 480 (defscriptmacro 1+ (form)
 481   `(+ ,form 1))
 482
 483 ;;; macros
 484 (defmacro with-temp-macro-environment ((var) &body body)
 485   `(let* ((,var (make-macro-env-dictionary))
 486           (*script-macro-env* (cons ,var *script-macro-env*)))
 487     ,@body))
 488
 489 (define-script-special-form macrolet (macros &body body)
 490   (with-temp-macro-environment (macro-env-dict)
 491     (dolist (macro macros)
 492       (destructuring-bind (name arglist &body body)
 493           macro
 494         (setf (get-macro-spec name macro-env-dict)
 495               (cons nil (let ((args (gensym "ps-macrolet-args-")))
 496                           (compile nil `(lambda (&rest ,args)
 497                                          (destructuring-bind ,arglist
 498                                              ,args
 499                                            ,@body))))))))
 500     (compile-script-form `(progn ,@body))))
 501
 502 (define-script-special-form symbol-macrolet (symbol-macros &body body)
 503   (with-temp-macro-environment (macro-env-dict)
 504     (dolist (macro symbol-macros)
 505       (destructuring-bind (name &body expansion)
 506           macro
 507         (setf (get-macro-spec name macro-env-dict)
 508               (cons t (compile nil `(lambda () ,@expansion))))))
 509     (compile-script-form `(progn ,@body))))
 510
 511 (defscriptmacro defmacro (name args &body body)
 512   `(lisp (defscriptmacro ,name ,args ,@body) nil))
 513
 514 (defscriptmacro lisp (&body forms)
 515   "Evaluates the given forms in Common Lisp at ParenScript
 516 macro-expansion time. The value of the last form is treated as a
 517 ParenScript expression and is inserted into the generated Javascript
 518 (use nil for no-op)."
 519   (eval (cons 'progn forms)))
 520
 521
 522 (defscriptmacro rebind (variables expression)
 523   "Creates a new js lexical environment and copies the given
 524   variable(s) there.  Executes the body in the new environment. This
 525   has the same effect as a new (let () ...) form in lisp but works on
 526   the js side for js closures."
 527   (unless (listp variables)
 528     (setf variables (list variables)))
 529   `((lambda ()
 530       (let ((new-context (new *object)))
 531         ,@(loop for variable in variables
 532                 do (setf variable (symbol-to-js variable))
 533                 collect `(setf (slot-value new-context ,variable) (slot-value this ,variable)))
 534         (with new-context
 535               (return ,expression))))))
 536
 537 ;;; Math library
 538 (defscriptmacro floor (expr)
 539   `(*Math.floor ,expr))
 540
 541 (defscriptmacro random ()
 542   `(*Math.random))
 543
 544 (defscriptmacro evenp (num)
 545   `(= (% ,num 2) 0))
 546
 547 (defscriptmacro oddp (num)
 548   `(= (% ,num 2) 1))
 549
 550 ;;; helper macros
 551 (define-script-special-form js (&rest body)
 552   (make-instance 'string-literal
 553                  :value (string-join (js-to-statement-strings
 554                                       (compile-script-form (cons 'progn body)) 0) " ")))
 555
 556 (define-script-special-form script-inline (&rest body)
 557   (make-instance 'string-literal
 558                  :value (concatenate
 559                          'string
 560                          "javascript:"
 561                          (string-join (js-to-statement-strings
 562                                        (compile-script-form (cons 'progn body)) 0) " "))))
 563 (defscriptmacro js-inline (&rest body)
 564   `(script-inline ,@body))
 565
 566 ;;; dual lisp/parenscript macro balderdash
 567 ;;; TODO: should probably move elsewhere ;;;
 568 (defmacro defmacro/js (name args &body body)
 569   "Define a Lisp macro and import it into the ParenScript macro environment."
 570   `(progn (defmacro ,name ,args ,@body)
 571           (js:import-macros-from-lisp ',name)))
 572
 573 (defmacro defmacro+js (name args &body body)
 574   "Define a Lisp macro and a ParenScript macro in their respective
 575 macro environments. This function should be used when you want to use
 576 the same macro in both Lisp and ParenScript, but the 'macroexpand' of
 577 that macro in Lisp makes the Lisp macro unsuitable to be imported into
 578 the ParenScript macro environment."
 579   `(progn (defmacro ,name ,args ,@body)
 580     (defscriptmacro ,name ,args ,@body)))
 581
 582 (defun import-macros-from-lisp (&rest names)
 583   "Import the named Lisp macros into the ParenScript macro environment."
 584   (dolist (name names)
 585     (let ((name name))
 586       (undefine-js-special-form name)
 587       (setf (get-macro-spec name *script-macro-toplevel*)
 588             (cons nil (lambda (&rest args)
 589                         (macroexpand `(,name ,@args))))))))
 590
 591 (defmacro js-file (&rest body)
 592   `(html
 593     (:princ
 594      (js ,@body))))
 595
 596 (defmacro js-script (&rest body)
 597   `((:script :type "text/javascript")
 598     (:princ (format nil "~%// <![CDATA[~%"))
 599     (:princ (js ,@body))
 600     (:princ (format nil "~%// ]]>~%"))))
 601
 602 (defmacro js-inline (&rest body)
 603   `(js-inline* '(progn ,@body)))
 604
 605 (defmacro js-inline* (&rest body)
 606   "Just like JS-INLINE except that BODY is evaluated before being
 607 converted to javascript."
 608   `(concatenate 'string "javascript:"
 609     (string-join (js-to-statement-strings (compile-script-form (list 'progn ,@body)) 0) " ")))