src/js-macrology.lisp

   1 (in-package :parenscript.javascript)
   2
   3 ;;;; The macrology of the basic Javascript-in-SEXPs language.  Special forms and macros.
   4
   5 ;;; literals
   6 (defmacro defscriptliteral (name string)
   7   "Define a Javascript literal that will expand to STRING."
   8   `(define-script-special-form ,name () (make-instance 'expression :value ,string)))
   9
  10 (defscriptliteral this      "this")
  11 (defscriptliteral t         "true")
  12 (defscriptliteral true      "true")
  13 (defscriptliteral false     "false")
  14 (defscriptliteral f         "false")
  15 (defscriptliteral nil       "null")
  16 (defscriptliteral undefined "undefined")
  17
  18 (defmacro defscriptkeyword (name string)
  19   "Define a Javascript keyword that will expand to STRING."
  20   `(define-script-special-form ,name () (make-instance 'statement :value ,string)))
  21
  22 (defscriptkeyword break    "break")
  23 (defscriptkeyword continue "continue")
  24
  25 ;;; array literals
  26 (define-script-special-form array (&rest values)
  27   (make-instance 'array-literal
  28                  :values (mapcar #'compile-to-expression values)))
  29
  30 (define-script-special-form aref (array &rest coords)
  31   (make-instance 'js-aref
  32                  :array (compile-to-expression array)
  33                  :index (mapcar #'compile-to-expression coords)))
  34
  35
  36 ;;; object literals (maps and hash-tables)
  37 (define-script-special-form {} (&rest values)
  38   (make-instance 'object-literal
  39                  :values (loop
  40                             for (key value) on values by #'cddr
  41                             collect (cons key (compile-to-expression value)))))
  42
  43 ;;; operators
  44 (define-script-special-form ++ (x)
  45   (make-instance 'one-op :pre-p nil :op "++"
  46                  :value (compile-to-expression x)))
  47
  48 (define-script-special-form -- (x)
  49   (make-instance 'one-op :pre-p nil :op "--"
  50                  :value (compile-to-expression x)))
  51
  52 (define-script-special-form incf (x &optional (delta 1))
  53   (if (eql delta 1)
  54       (make-instance 'one-op :pre-p t :op "++"
  55                      :value (compile-to-expression x))
  56       (make-instance 'op-form
  57                      :operator '+=
  58                      :args (mapcar #'compile-to-expression
  59                                    (list x delta )))))
  60
  61 (define-script-special-form decf (x &optional (delta 1))
  62   (if (eql delta 1)
  63       (make-instance 'one-op :pre-p t :op "--"
  64                      :value (compile-to-expression x))
  65       (make-instance 'op-form
  66                      :operator '-=
  67                      :args (mapcar #'compile-to-expression
  68                                    (list x delta )))))
  69
  70 (define-script-special-form - (first &rest rest)
  71   (if (null rest)
  72       (make-instance 'one-op
  73                      :pre-p t
  74                      :op "-"
  75                      :value (compile-to-expression first))
  76       (make-instance 'op-form
  77                      :operator '-
  78                      :args (mapcar #'compile-to-expression
  79                                    (cons first rest)))))
  80
  81 (define-script-special-form not (x)
  82   (let ((value (compile-to-expression x)))
  83     (if (and (typep value 'op-form)
  84              (= (length (op-args value)) 2))
  85         (let ((new-op (case (operator value)
  86                         (== '!=)
  87                         (< '>=)
  88                         (> '<=)
  89                         (<= '>)
  90                         (>= '<)
  91                         (!= '==)
  92                         (=== '!==)
  93                         (!== '===)
  94                         (t nil))))
  95           (if new-op
  96               (make-instance 'op-form :operator new-op
  97                              :args (op-args value))
  98               (make-instance 'one-op :pre-p t :op "!"
  99                             :value value)))
 100         (make-instance 'one-op :pre-p t :op "!"
 101                        :value value))))
 102
 103 (define-script-special-form ~ (x)
 104   (let ((expr (compile-to-expression x)))
 105     (make-instance 'one-op :pre-p t :op "~" :value expr)))
 106
 107 (define-script-special-form progn (&rest body)
 108   (make-instance 'js-block :statements (mapcar #'compile-to-statement body)))
 109
 110 (defmethod expression-precedence ((body js-block))
 111   (if (= (length (block-statements body)) 1)
 112       (expression-precedence (first (block-statements body)))
 113       (op-precedence 'comma)))
 114
 115 ;;; function definition
 116 (define-script-special-form %js-lambda (args &rest body)
 117   (make-instance 'js-lambda
 118                  :args (mapcar #'compile-to-symbol args)
 119                  :body (make-instance 'js-block
 120                                       :indent "  "
 121                                       :statements (mapcar #'compile-to-statement body))))
 122
 123 (define-script-special-form %js-defun (name args &rest body)
 124   (make-instance 'js-defun
 125                  :name (compile-to-symbol name)
 126                  :args (mapcar #'compile-to-symbol args)
 127                  :body (make-instance 'js-block
 128                                       :indent "  "
 129                                       :statements (mapcar #'compile-to-statement body))))
 130
 131 ;;; object creation
 132 (define-script-special-form create (&rest args)
 133   (make-instance 'js-object
 134                  :slots (loop for (name val) on args by #'cddr
 135                               collect (let ((name-expr (compile-to-expression name)))
 136                                         (assert (or (typep name-expr 'js-variable)
 137                                                     (typep name-expr 'script-quote)
 138                                                     (typep name-expr 'string-literal)
 139                                                     (typep name-expr 'number-literal)))
 140                                         (list name-expr (compile-to-expression val))))))
 141
 142
 143 (define-script-special-form %js-slot-value (obj slot)
 144   (if (ps::expand-script-form slot)
 145       (make-instance 'js-slot-value
 146                      :object (compile-to-expression obj)
 147                      :slot (compile-script-form slot))
 148       (compile-to-expression obj)))
 149
 150 ;;; cond
 151 (define-script-special-form cond (&rest clauses)
 152   (make-instance 'js-cond
 153                  :tests (mapcar (lambda (clause) (compile-to-expression (car clause)))
 154                                 clauses)
 155                  :bodies (mapcar (lambda (clause) (compile-to-block (cons 'progn (cdr clause)) :indent "  "))
 156                                  clauses)))
 157
 158 ;;; if
 159 (define-script-special-form if (test then &optional else)
 160   (make-instance 'js-if :test (compile-to-expression test)
 161                  :then (compile-to-block then :indent "  ")
 162                  :else (when else
 163                          (compile-to-block else :indent "  "))))
 164
 165 (defmethod expression-precedence ((if js-if))
 166   (op-precedence 'if))
 167
 168 ;;; switch
 169 (define-script-special-form switch (value &rest clauses)
 170   (let ((clauses (mapcar #'(lambda (clause)
 171                              (let ((val (first clause))
 172                                    (body (cdr clause)))
 173                                (list (if (eql val 'default)
 174                                          'default
 175                                          (compile-to-expression val))
 176                                      (compile-to-block (cons 'progn body) :indent "  "))))
 177                          clauses))
 178         (check (compile-to-expression value)))
 179     (make-instance 'js-switch :value check
 180                    :clauses clauses)))
 181
 182
 183 ;;; assignment
 184 (defun assignment-op (op)
 185   (case op
 186     (+ '+=)
 187     (~ '~=)
 188     (\& '\&=)
 189     (\| '\|=)
 190     (- '-=)
 191     (* '*=)
 192     (% '%=)
 193     (>> '>>=)
 194     (^  '^=)
 195     (<< '<<=)
 196     (>>> '>>>=)
 197     (/   '/=)
 198     (t   nil)))
 199
 200 (defun make-js-test (lhs rhs)
 201   (if (and (typep rhs 'op-form)
 202            (member lhs (op-args rhs) :test #'script-equal))
 203       (let ((args-without (remove lhs (op-args rhs)
 204                                   :count 1 :test #'script-equal))
 205             (args-without-first (remove lhs (op-args rhs)
 206                                         :count 1 :end 1
 207                                         :test #'script-equal))
 208             (one (list (make-instance 'number-literal :value 1))))
 209         #+nil
 210         (format t "OPERATOR: ~S, ARGS-WITHOUT: ~S, ARGS-WITHOUT-FIRST ~S~%"
 211                 (operator rhs)
 212                 args-without
 213                 args-without-first)
 214         (cond ((and (script-equal args-without one)
 215                     (eql (operator rhs) '+))
 216                (make-instance 'one-op :pre-p nil :op "++"
 217                               :value lhs))
 218               ((and (script-equal args-without-first one)
 219                     (eql (operator rhs) '-))
 220                (make-instance 'one-op :pre-p nil :op "--"
 221                               :value lhs))
 222               ((and (assignment-op (operator rhs))
 223                     (member (operator rhs)
 224                             '(+ *))
 225                     (script-equal lhs (first (op-args rhs))))
 226                (make-instance 'op-form
 227                               :operator (assignment-op (operator rhs))
 228                               :args (list lhs (make-instance 'op-form
 229                                                              :operator (operator rhs)
 230                                                              :args args-without-first))))
 231               ((and (assignment-op (operator rhs))
 232                     (script-equal (first (op-args rhs)) lhs))
 233                (make-instance 'op-form
 234                               :operator (assignment-op (operator rhs))
 235                               :args (list lhs (make-instance 'op-form
 236                                                              :operator (operator rhs)
 237                                                              :args (cdr (op-args rhs))))))
 238               (t (make-instance 'js-setf :lhs lhs :rhsides (list rhs)))))
 239       (make-instance 'js-setf :lhs lhs :rhsides (list rhs))))
 240
 241 (define-script-special-form setf1% (lhs rhs)
 242   (make-js-test (compile-to-expression lhs) (compile-to-expression rhs)))
 243
 244 (defmethod expression-precedence ((setf js-setf))
 245   (op-precedence '=))
 246
 247 ;;; defvar
 248 (define-script-special-form defvar (name &optional value)
 249   (make-instance 'js-defvar :names (list (compile-to-symbol name))
 250                  :value (when value (compile-to-expression value))))
 251
 252 ;;; iteration
 253 (defun make-for-vars (decls)
 254   (loop for decl in decls
 255         for var = (if (atom decl) decl (first decl))
 256         for init = (if (atom decl) nil (second decl))
 257         collect (make-instance 'js-defvar :names (list (compile-to-symbol var))
 258                                :value (compile-to-expression init))))
 259
 260 (defun make-for-steps (decls)
 261   (loop for decl in decls
 262         when (= (length decl) 3)
 263         collect (compile-to-expression (third decl))))
 264
 265 (define-script-special-form do (decls termination &rest body)
 266   (let ((vars (make-for-vars decls))
 267         (steps (make-for-steps decls))
 268         (check (compile-to-expression (list 'not (first termination))))
 269         (body (compile-to-block (cons 'progn body) :indent "  ")))
 270     (make-instance 'js-for
 271                    :vars vars
 272                    :steps steps
 273                    :check check
 274                    :body body)))
 275
 276 (define-script-special-form doeach (decl &rest body)
 277   (make-instance 'for-each :name (compile-to-symbol (first decl))
 278                  :value (compile-to-expression (second decl))
 279                  :body (compile-to-block (cons 'progn body) :indent "  ")))
 280
 281 (define-script-special-form while (check &rest body)
 282   (make-instance 'js-while
 283                  :check (compile-to-expression check)
 284                  :body (compile-to-block (cons 'progn body) :indent "  ")))
 285
 286 ;;; with
 287 (define-script-special-form with (statement &rest body)
 288   (make-instance 'js-with
 289                  :obj (compile-to-expression statement)
 290                  :body (compile-to-block (cons 'progn body) :indent "  ")))
 291
 292
 293 ;;; try-catch
 294 (define-script-special-form try (body &rest clauses)
 295   (let ((body (compile-to-block body :indent "  "))
 296         (catch (cdr (assoc :catch clauses)))
 297         (finally (cdr (assoc :finally clauses))))
 298     (assert (not (cdar catch)) nil "Sorry, currently only simple catch forms are supported.")
 299     (make-instance 'js-try
 300                    :body body
 301                    :catch (when catch (list (compile-to-symbol (caar catch))
 302                                             (compile-to-block (cons 'progn (cdr catch))
 303                                                                 :indent "  ")))
 304                    :finally (when finally (compile-to-block (cons 'progn finally)
 305                                                               :indent "  ")))))
 306 ;;; regex
 307 (define-script-special-form regex (regex)
 308   (make-instance 'regex :value (string regex)))
 309
 310 ;;; TODO instanceof
 311 (define-script-special-form instanceof (value type)
 312   (make-instance 'js-instanceof
 313                  :value (compile-to-expression value)
 314                  :type (compile-to-expression type)))
 315
 316 ;;; single operations
 317 (defmacro define-parse-script-single-op (name &optional (superclass 'expression))
 318   (let ((script-name (intern (concatenate 'string "JS-" (symbol-name name)) #.*package*)))
 319     `(define-script-special-form ,name (value)
 320        (make-instance ',script-name :value (compile-to-expression value)))
 321     ))
 322
 323 (define-parse-script-single-op throw statement)
 324 (define-parse-script-single-op delete)
 325 (define-parse-script-single-op void)
 326 (define-parse-script-single-op typeof)
 327 (define-parse-script-single-op new)
 328
 329 (define-script-special-form return (&optional value)
 330   (make-instance 'js-return :value (compile-to-expression value)))
 331
 332 ;;; conditional compilation
 333 (define-script-special-form cc-if (test &rest body)
 334   (make-instance 'cc-if :test test
 335                  :body (mapcar #'compile-script-form body)))
 336
 337 ;;; standard macros
 338 (defscriptmacro when (test &rest body)
 339   `(if ,test (progn ,@body)))
 340
 341 (defscriptmacro unless (test &rest body)
 342   `(if (not ,test) (progn ,@body)))
 343
 344 (defscriptmacro 1- (form)
 345   `(- ,form 1))
 346
 347 (defscriptmacro 1+ (form)
 348   `(+ ,form 1))
 349
 350 ;;; helper macros
 351 (define-script-special-form js (&rest body)
 352   (make-instance 'string-literal
 353                  :value (string-join (js-to-statement-strings
 354                                       (compile-script-form (cons 'progn body)) 0) " ")))
 355
 356 (define-script-special-form script-inline (&rest body)
 357   (make-instance 'string-literal
 358                  :value (concatenate
 359                          'string
 360                          "javascript:"
 361                          (string-join (js-to-statement-strings
 362                                        (compile-script-form (cons 'progn body)) 0) " "))))
 363 (defscriptmacro parenscript::js-inline (&rest body)
 364   `(script-inline ,@body))