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