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 ;;; progn
 108 (define-script-special-form progn (&rest body)
 109   (make-instance 'js-block
 110                  :statements (mapcar #'compile-to-statement body)))
 111
 112 (defmethod expression-precedence ((body js-block))
 113   (if (= (length (block-statements body)) 1)
 114       (expression-precedence (first (block-statements body)))
 115       (op-precedence 'comma)))
 116
 117 ;;; function definition
 118 (define-script-special-form lambda (args &rest body)
 119   (make-instance 'js-lambda
 120                  :args (mapcar #'compile-to-symbol args)
 121                  :body (make-instance 'js-block
 122                                       :indent "  "
 123                                       :statements (mapcar #'compile-to-statement body))))
 124
 125 (define-script-special-form defun (name args &rest body)
 126   (make-instance 'js-defun
 127                  :name (compile-to-symbol name)
 128                  :args (mapcar #'compile-to-symbol args)
 129                  :body (make-instance 'js-block
 130                                       :indent "  "
 131                                       :statements (mapcar #'compile-to-statement body))))
 132
 133 ;;; object creation
 134 (define-script-special-form create (&rest args)
 135   (make-instance 'js-object
 136                  :slots (loop for (name val) on args by #'cddr
 137                               collect (let ((name-expr (compile-to-expression name)))
 138                                         (assert (or (typep name-expr 'js-variable)
 139                                                     (typep name-expr 'string-literal)
 140                                                     (typep name-expr 'number-literal)))
 141                                         (list name-expr (compile-to-expression val))))))
 142
 143
 144 (define-script-special-form slot-value (obj slot)
 145   (make-instance 'js-slot-value :object (compile-to-expression obj)
 146                    :slot (compile-script-form slot)))
 147
 148 ;;; cond
 149 (define-script-special-form cond (&rest clauses)
 150   (make-instance 'js-cond
 151                  :tests (mapcar (lambda (clause) (compile-to-expression (car clause)))
 152                                 clauses)
 153                  :bodies (mapcar (lambda (clause) (compile-to-block (cons 'progn (cdr clause)) :indent "  "))
 154                                  clauses)))
 155
 156 ;;; if
 157 (define-script-special-form if (test then &optional else)
 158   (make-instance 'js-if :test (compile-to-expression test)
 159                  :then (compile-to-block then :indent "  ")
 160                  :else (when else
 161                          (compile-to-block else :indent "  "))))
 162
 163 (defmethod expression-precedence ((if js-if))
 164   (op-precedence 'if))
 165
 166 ;;; switch
 167 (define-script-special-form switch (value &rest clauses)
 168   (let ((clauses (mapcar #'(lambda (clause)
 169                              (let ((val (first clause))
 170                                    (body (cdr clause)))
 171                                (list (if (eql val 'default)
 172                                          'default
 173                                          (compile-to-expression val))
 174                                      (compile-to-block (cons 'progn body) :indent "  "))))
 175                          clauses))
 176         (check (compile-to-expression value)))
 177     (make-instance 'js-switch :value check
 178                    :clauses clauses)))
 179
 180
 181 ;;; assignment
 182 (defun assignment-op (op)
 183   (case op
 184     (+ '+=)
 185     (~ '~=)
 186     (\& '\&=)
 187     (\| '\|=)
 188     (- '-=)
 189     (* '*=)
 190     (% '%=)
 191     (>> '>>=)
 192     (^  '^=)
 193     (<< '<<=)
 194     (>>> '>>>=)
 195     (/   '/=)
 196     (t   nil)))
 197
 198 (defun make-js-test (lhs rhs)
 199   (if (and (typep rhs 'op-form)
 200            (member lhs (op-args rhs) :test #'js-equal))
 201       (let ((args-without (remove lhs (op-args rhs)
 202                                   :count 1 :test #'js-equal))
 203             (args-without-first (remove lhs (op-args rhs)
 204                                         :count 1 :end 1
 205                                         :test #'js-equal))
 206             (one (list (make-instance 'number-literal :value 1))))
 207         #+nil
 208         (format t "OPERATOR: ~S, ARGS-WITHOUT: ~S, ARGS-WITHOUT-FIRST ~S~%"
 209                 (operator rhs)
 210                 args-without
 211                 args-without-first)
 212         (cond ((and (js-equal args-without one)
 213                     (eql (operator rhs) '+))
 214                (make-instance 'one-op :pre-p nil :op "++"
 215                               :value lhs))
 216               ((and (js-equal args-without-first one)
 217                     (eql (operator rhs) '-))
 218                (make-instance 'one-op :pre-p nil :op "--"
 219                               :value lhs))
 220               ((and (assignment-op (operator rhs))
 221                     (member (operator rhs)
 222                             '(+ *))
 223                     (js-equal lhs (first (op-args rhs))))
 224                (make-instance 'op-form
 225                               :operator (assignment-op (operator rhs))
 226                               :args (list lhs (make-instance 'op-form
 227                                                              :operator (operator rhs)
 228                                                              :args args-without-first))))
 229               ((and (assignment-op (operator rhs))
 230                     (js-equal (first (op-args rhs)) lhs))
 231                (make-instance 'op-form
 232                               :operator (assignment-op (operator rhs))
 233                               :args (list lhs (make-instance 'op-form
 234                                                              :operator (operator rhs)
 235                                                              :args (cdr (op-args rhs))))))
 236               (t (make-instance 'js-setf :lhs lhs :rhsides (list rhs)))))
 237       (make-instance 'js-setf :lhs lhs :rhsides (list rhs))))
 238
 239 (define-script-special-form setf (&rest args)
 240   (let ((assignments (loop for (lhs rhs) on args by #'cddr
 241                            for rexpr = (compile-to-expression rhs)
 242                            for lexpr = (compile-to-expression lhs)
 243                            collect (make-js-test lexpr rexpr))))
 244     (if (= (length assignments) 1)
 245         (first assignments)
 246         (make-instance 'js-block :indent "" :statements assignments))))
 247
 248 (defmethod expression-precedence ((setf js-setf))
 249   (op-precedence '=))
 250
 251 ;;; defvar
 252 (define-script-special-form defvar (name &optional value)
 253   (make-instance 'js-defvar :names (list (compile-to-symbol name))
 254                  :value (when value (compile-to-expression value))))
 255
 256 ;;; iteration
 257 (defun make-for-vars (decls)
 258   (loop for decl in decls
 259         for var = (if (atom decl) decl (first decl))
 260         for init = (if (atom decl) nil (second decl))
 261         collect (make-instance 'js-defvar :names (list (compile-to-symbol var))
 262                                :value (compile-to-expression init))))
 263
 264 (defun make-for-steps (decls)
 265   (loop for decl in decls
 266         when (= (length decl) 3)
 267         collect (compile-to-expression (third decl))))
 268
 269 (define-script-special-form do (decls termination &rest body)
 270   (let ((vars (make-for-vars decls))
 271         (steps (make-for-steps decls))
 272         (check (compile-to-expression (list 'not (first termination))))
 273         (body (compile-to-block (cons 'progn body) :indent "  ")))
 274     (make-instance 'js-for
 275                    :vars vars
 276                    :steps steps
 277                    :check check
 278                    :body body)))
 279
 280 (define-script-special-form doeach (decl &rest body)
 281   (make-instance 'for-each :name (compile-to-symbol (first decl))
 282                  :value (compile-to-expression (second decl))
 283                  :body (compile-to-block (cons 'progn body) :indent "  ")))
 284
 285 (define-script-special-form while (check &rest body)
 286   (make-instance 'js-while
 287                  :check (compile-to-expression check)
 288                  :body (compile-to-block (cons 'progn body) :indent "  ")))
 289
 290 ;;; with
 291 (define-script-special-form with (statement &rest body)
 292   (make-instance 'js-with
 293                  :obj (compile-to-expression statement)
 294                  :body (compile-to-block (cons 'progn body) :indent "  ")))
 295
 296
 297 ;;; try-catch
 298 (define-script-special-form try (body &rest clauses)
 299   (let ((body (compile-to-block body :indent "  "))
 300         (catch (cdr (assoc :catch clauses)))
 301         (finally (cdr (assoc :finally clauses))))
 302     (assert (not (cdar catch)) nil "Sorry, currently only simple catch forms are supported.")
 303     (make-instance 'js-try
 304                    :body body
 305                    :catch (when catch (list (compile-to-symbol (caar catch))
 306                                             (compile-to-block (cons 'progn (cdr catch))
 307                                                                 :indent "  ")))
 308                    :finally (when finally (compile-to-block (cons 'progn finally)
 309                                                               :indent "  ")))))
 310 ;;; regex
 311 (define-script-special-form regex (regex)
 312   (make-instance 'regex :value (string regex)))
 313
 314 ;;; TODO instanceof
 315 (define-script-special-form instanceof (value type)
 316   (make-instance 'js-instanceof
 317                  :value (compile-to-expression value)
 318                  :type (compile-to-expression type)))
 319
 320 ;;; single operations
 321 (defmacro define-parse-script-single-op (name &optional (superclass 'expression))
 322   (let ((script-name (intern (concatenate 'string "JS-" (symbol-name name)) #.*package*)))
 323     `(define-script-special-form ,name (value)
 324        (make-instance ',script-name :value (compile-to-expression value)))
 325     ))
 326
 327 (define-parse-script-single-op return statement)
 328 (define-parse-script-single-op throw statement)
 329 (define-parse-script-single-op delete)
 330 (define-parse-script-single-op void)
 331 (define-parse-script-single-op typeof)
 332 (define-parse-script-single-op new)
 333
 334 ;;; conditional compilation
 335 (define-script-special-form cc-if (test &rest body)
 336   (make-instance 'cc-if :test test
 337                  :body (mapcar #'compile-script-form body)))
 338
 339 ;;; standard macros
 340 (defscriptmacro with-slots (slots object &rest body)
 341   `(symbol-macrolet ,(mapcar #'(lambda (slot)
 342                                  `(,slot '(slot-value ,object ',slot)))
 343                              slots)
 344     ,@body))
 345
 346 (defscriptmacro when (test &rest body)
 347   `(if ,test (progn ,@body)))
 348
 349 (defscriptmacro unless (test &rest body)
 350   `(if (not ,test) (progn ,@body)))
 351
 352 (defscriptmacro 1- (form)
 353   `(- ,form 1))
 354
 355 (defscriptmacro 1+ (form)
 356   `(+ ,form 1))
 357
 358 ;;; helper macros
 359 (define-script-special-form js (&rest body)
 360   (make-instance 'string-literal
 361                  :value (string-join (js-to-statement-strings
 362                                       (compile-script-form (cons 'progn body)) 0) " ")))
 363
 364 (define-script-special-form script-inline (&rest body)
 365   (make-instance 'string-literal
 366                  :value (concatenate
 367                          'string
 368                          "javascript:"
 369                          (string-join (js-to-statement-strings
 370                                        (compile-script-form (cons 'progn body)) 0) " "))))
 371 (defscriptmacro js-inline (&rest body)
 372   `(script-inline ,@body))