src/js-macrology.lisp

   1 (in-package :parenscript)
   2
   3 ;;;; The macrology of the basic Javascript-in-SEXPs language.  Special forms and macros.
   4
   5 ;;; literals
   6 (defmacro defpsliteral (name string)
   7   `(define-ps-special-form ,name (expecting)
   8     (declare (ignore expecting))
   9     (list 'js-literal ,string)))
  10
  11 (defpsliteral this      "this")
  12 (defpsliteral t         "true")
  13 (defpsliteral true      "true")
  14 (defpsliteral false     "false")
  15 (defpsliteral f         "false")
  16 (defpsliteral nil       "null")
  17 (defpsliteral undefined "undefined")
  18
  19 (defmacro defpskeyword (name string)
  20   `(define-ps-special-form ,name (expecting)
  21     (declare (ignore expecting))
  22     (list 'js-keyword ,string)))
  23
  24 (defpskeyword break    "break")
  25 (defpskeyword continue "continue")
  26
  27 (define-ps-special-form array (expecting &rest values)
  28   (declare (ignore expecting))
  29   (cons 'array-literal (mapcar (lambda (form) (compile-parenscript-form form :expecting :expression))
  30                                values)))
  31
  32 (define-ps-special-form aref (expecting array &rest coords)
  33   (declare (ignore expecting))
  34   (list 'js-aref (compile-parenscript-form array :expecting :expression)
  35         (mapcar (lambda (form)
  36                   (compile-parenscript-form form :expecting :expression))
  37                 coords)))
  38
  39 (define-ps-special-form {} (expecting &rest arrows)
  40   (declare (ignore expecting))
  41   (cons 'object-literal (loop for (key value) on arrows by #'cddr
  42                               collect (cons key (compile-parenscript-form value :expecting :expression)))))
  43
  44 ;;; operators
  45 (define-ps-special-form incf (expecting x &optional (delta 1))
  46   (declare (ignore expecting))
  47   (if (equal delta 1)
  48       (list 'unary-operator "++" (compile-parenscript-form x :expecting :expression) :prefix t)
  49       (list 'operator '+= (list (compile-parenscript-form x :expecting :expression)
  50                                 (compile-parenscript-form delta :expecting :expression)))))
  51
  52 (define-ps-special-form decf (expecting x &optional (delta 1))
  53   (declare (ignore expecting))
  54   (if (equal delta 1)
  55       (list 'unary-operator "--" (compile-parenscript-form x :expecting :expression) :prefix t)
  56       (list 'operator '-= (list (compile-parenscript-form x :expecting :expression)
  57                                 (compile-parenscript-form delta :expecting :expression)))))
  58
  59 (define-ps-special-form - (expecting first &rest rest)
  60   (declare (ignore expecting))
  61   (if (null rest)
  62       (list 'unary-operator "-" (compile-parenscript-form first :expecting :expression) :prefix t)
  63       (list 'operator '- (mapcar (lambda (val) (compile-parenscript-form val :expecting :expression))
  64                                  (cons first rest)))))
  65
  66 (define-ps-special-form not (expecting x)
  67   (declare (ignore expecting))
  68   (let ((form (compile-parenscript-form x :expecting :expression))
  69         (not-op nil))
  70     (if (and (eql (first form) 'operator)
  71              (= (length (third form)) 2)
  72              (setf not-op (case (second form)
  73                             (== '!=)
  74                             (< '>=)
  75                             (> '<=)
  76                             (<= '>)
  77                             (>= '<)
  78                             (!= '==)
  79                             (=== '!==)
  80                             (!== '===)
  81                             (t nil))))
  82         (list 'operator not-op (third form))
  83         (list 'unary-operator "!" form :prefix t))))
  84
  85 (define-ps-special-form ~ (expecting x)
  86   (declare (ignore expecting))
  87   (list 'unary-operator "~" (compile-parenscript-form x :expecting :expressin) :prefix t))
  88
  89 (defun flatten-blocks (body)
  90   (when body
  91     (if (and (listp (car body))
  92              (eql 'js-block (caar body)))
  93         (append (third (car body)) (flatten-blocks (cdr body)))
  94         (cons (car body) (flatten-blocks (cdr body))))))
  95
  96 (define-ps-special-form progn (expecting &rest body)
  97   (if (and (eql expecting :expression) (= 1 (length body)))
  98       (compile-parenscript-form (car body) :expecting :expression)
  99       (list 'js-block
 100             (if (eql expecting :statement) t nil)
 101             (let* ((block (mapcar (lambda (form)
 102                                     (compile-parenscript-form form :expecting :statement))
 103                                   body))
 104                    (clean-block (remove nil block))
 105                    (flat-block (flatten-blocks clean-block))
 106                    (reachable-block (append (remove-if #'constant-literal-form-p (butlast flat-block))
 107                                             (last flat-block))))
 108               reachable-block))))
 109
 110 ;;; function definition
 111 (define-ps-special-form %js-lambda (expecting args &rest body)
 112   (declare (ignore expecting))
 113   (list 'js-lambda (mapcar (lambda (arg)
 114                              (compile-parenscript-form arg :expecting :symbol))
 115                            args)
 116         (compile-parenscript-form `(progn ,@body))))
 117
 118 (define-ps-special-form %js-defun (expecting name args &rest body)
 119   (declare (ignore expecting))
 120   (list 'js-defun name
 121         (mapcar (lambda (val) (compile-parenscript-form val :expecting :symbol)) args)
 122         (compile-parenscript-form `(progn ,@body))))
 123
 124 ;;; object creation
 125 (define-ps-special-form create (expecting &rest args)
 126   (declare (ignore expecting))
 127   (list 'js-object (loop for (name val) on args by #'cddr collecting
 128                          (let ((name-expr (compile-parenscript-form name :expecting :expression)))
 129                            (assert (or (stringp name-expr)
 130                                        (numberp name-expr)
 131                                        (and (listp name-expr)
 132                                             (or (eql 'js-variable (car name-expr))
 133                                                 (eql 'script-quote (car name-expr)))))
 134                                    ()
 135                                    "Slot ~s is not one of js-variable, keyword, string or number." name-expr)
 136                            (list name-expr (compile-parenscript-form val :expecting :expression))))))
 137
 138 (define-ps-special-form %js-slot-value (expecting obj slot)
 139   (declare (ignore expecting))
 140   (if (ps::ps-macroexpand slot)
 141       (list 'js-slot-value (compile-parenscript-form obj :expecting :expression) (compile-parenscript-form slot))
 142       (compile-parenscript-form obj :expecting :expression)))
 143
 144 (define-ps-special-form cond (expecting &rest clauses)
 145   (ecase expecting
 146     (:statement (list 'js-cond-statement
 147                       (mapcar (lambda (clause)
 148                                 (destructuring-bind (test &rest body)
 149                                     clause
 150                                   (list (compile-parenscript-form test :expecting :expression)
 151                                         (compile-parenscript-form `(progn ,@body)))))
 152                               clauses)))
 153     (:expression (make-cond-clauses-into-nested-ifs clauses))))
 154
 155 (defun make-cond-clauses-into-nested-ifs (clauses)
 156   (if clauses
 157       (destructuring-bind (test &rest body)
 158           (car clauses)
 159         (if (eq t test)
 160             (compile-parenscript-form `(progn ,@body) :expecting :expression)
 161             (list 'js-expression-if (compile-parenscript-form test :expecting :expression)
 162                   (compile-parenscript-form `(progn ,@body) :expecting :expression)
 163                   (make-cond-clauses-into-nested-ifs (cdr clauses)))))
 164       (compile-parenscript-form nil :expecting :expression)))
 165
 166 (define-ps-special-form if (expecting test then &optional else)
 167   (ecase expecting
 168     (:statement (list 'js-statement-if (compile-parenscript-form test :expecting :expression)
 169                       (compile-parenscript-form `(progn ,then))
 170                       (when else (compile-parenscript-form `(progn ,else)))))
 171     (:expression (list 'js-expression-if (compile-parenscript-form test :expecting :expression)
 172                        (compile-parenscript-form then :expecting :expression)
 173                        (compile-parenscript-form else :expecting :expression)))))
 174
 175 (define-ps-special-form switch (expecting test-expr &rest clauses)
 176   (declare (ignore expecting))
 177   (let ((clauses (mapcar (lambda (clause)
 178                              (let ((val (car clause))
 179                                    (body (cdr clause)))
 180                                (list (if (eql val 'default)
 181                                          'default
 182                                          (compile-parenscript-form val :expecting :expression))
 183                                      (compile-parenscript-form `(progn ,@body)))))
 184                          clauses))
 185         (expr (compile-parenscript-form test-expr :expecting :expression)))
 186     (list 'js-switch expr clauses)))
 187
 188 ;;; assignment
 189 (defun assignment-op (op)
 190   (case op
 191     (+ '+=)
 192     (~ '~=)
 193     (\& '\&=)
 194     (\| '\|=)
 195     (- '-=)
 196     (* '*=)
 197     (% '%=)
 198     (>> '>>=)
 199     (^  '^=)
 200     (<< '<<=)
 201     (>>> '>>>=)
 202     (/   '/=)
 203     (t   nil)))
 204
 205 (defun smart-setf (lhs rhs)
 206   (if (and (listp rhs)
 207            (eql 'operator (car rhs))
 208            (member lhs (third rhs) :test #'equalp))
 209       (let ((args-without (remove lhs (third rhs) :count 1 :test #'equalp))
 210             (args-without-first (remove lhs (third rhs) :count 1 :end 1 :test #'equalp)))
 211         (cond ((and (equal (car args-without) 1) (eql (second rhs) '+))
 212                (list 'unary-operator "++" lhs :prefix nil))
 213               ((and (equal (second args-without-first) 1) (eql (second rhs) '-))
 214                (list 'unary-operator "--" lhs :prefix nil))
 215               ((and (assignment-op (second rhs))
 216                     (member (second rhs) '(+ *))
 217                     (equalp lhs (first (third rhs))))
 218                (list 'operator (assignment-op (second rhs))
 219                      (list lhs (list 'operator (second rhs) args-without-first))))
 220               ((and (assignment-op (second rhs)) (equalp (first (third rhs)) lhs))
 221                (list 'operator (assignment-op (second rhs))
 222                      (list lhs (list 'operator (second rhs) (cdr (third rhs))))))
 223               (t (list 'js-assign lhs rhs))))
 224       (list 'js-assign lhs rhs)))
 225
 226 (define-ps-special-form setf1% (expecting lhs rhs)
 227   (declare (ignore expecting))
 228   (smart-setf (compile-parenscript-form lhs :expecting :expression) (compile-parenscript-form rhs :expecting :expression)))
 229
 230 (define-ps-special-form defvar (expecting name &rest value)
 231   (declare (ignore expecting))
 232   (append (list 'js-defvar name)
 233           (when value
 234             (assert (= (length value) 1) () "Wrong number of arguments to defvar: ~s" `(defvar ,name ,@value))
 235            (list (compile-parenscript-form (car value) :expecting :expression)))))
 236
 237 ;;; iteration
 238 (defun make-for-vars (decls)
 239   (loop for decl in decls
 240         for var = (if (atom decl) decl (first decl))
 241         for init-value = (if (atom decl) nil (second decl))
 242         collect (cons (compile-parenscript-form var :expecting :symbol) (compile-parenscript-form init-value))))
 243
 244 (defun make-for-steps (decls)
 245   (loop for decl in decls
 246         when (= (length decl) 3)
 247         collect (compile-parenscript-form (third decl) :expecting :expression)))
 248
 249 (define-ps-special-form do (expecting decls termination-test &rest body)
 250   (declare (ignore expecting))
 251   (let ((vars (make-for-vars decls))
 252         (steps (make-for-steps decls))
 253         (test (compile-parenscript-form `(not ,(first termination-test)) :expecting :expression))
 254         (body (compile-parenscript-form `(progn ,@body))))
 255     (list 'js-for vars steps test body)))
 256
 257 (define-ps-special-form doeach (expecting decl &rest body)
 258   (declare (ignore expecting))
 259   (list 'js-for-each
 260         (first decl)
 261         (compile-parenscript-form (second decl) :expecting :expression)
 262         (compile-parenscript-form `(progn ,@body))))
 263
 264 (define-ps-special-form while (expecting test &rest body)
 265   (declare (ignore expecting))
 266   (list 'js-while (compile-parenscript-form test :expecting :expression)
 267                   (compile-parenscript-form `(progn ,@body))))
 268
 269 (define-ps-special-form with (expecting expression &rest body)
 270   (declare (ignore expecting))
 271   (list 'js-with (compile-parenscript-form expression :expecting :expression)
 272                  (compile-parenscript-form `(progn ,@body))))
 273
 274 (define-ps-special-form try (expecting form &rest clauses)
 275   (declare (ignore expecting))
 276   (let ((catch (cdr (assoc :catch clauses)))
 277         (finally (cdr (assoc :finally clauses))))
 278     (assert (not (cdar catch)) nil "Sorry, currently only simple catch forms are supported.")
 279     (assert (or catch finally) ()
 280             "Try form should have either a catch or a finally clause or both.")
 281     (list 'js-try (compile-parenscript-form `(progn ,form))
 282           :catch (when catch (list (compile-parenscript-form (caar catch) :expecting :symbol)
 283                                    (compile-parenscript-form `(progn ,@(cdr catch)))))
 284           :finally (when finally (compile-parenscript-form `(progn ,@finally))))))
 285
 286 (define-ps-special-form regex (expecting regex)
 287   (declare (ignore expecting))
 288   (list 'js-regex (string regex)))
 289
 290 ;;; TODO instanceof
 291 (define-ps-special-form instanceof (expecting value type)
 292   (declare (ignore expecting))
 293   (list 'js-instanceof (compile-parenscript-form value :expecting :expression)
 294         (compile-parenscript-form type :expecting :expression)))
 295
 296 ;;; single operations
 297 (mapcar (lambda (op) (eval `(define-ps-special-form ,op (expecting value)
 298                              (declare (ignore expecting))
 299                              (list 'js-named-operator ',op (compile-parenscript-form value)))))
 300         '(throw delete void typeof new))
 301
 302 (define-ps-special-form return (expecting &optional value)
 303   (declare (ignore expecting))
 304   (list 'js-return (compile-parenscript-form value :expecting :expression)))
 305
 306 ;;; conditional compilation
 307 (define-ps-special-form cc-if (expecting test &rest body)
 308   (declare (ignore expecting))
 309   (list 'cc-if test (mapcar #'compile-parenscript-form body)))
 310
 311 ;;; standard macros
 312 (defpsmacro when (test &rest body)
 313   `(if ,test (progn ,@body)))
 314
 315 (defpsmacro unless (test &rest body)
 316   `(if (not ,test) (progn ,@body)))
 317
 318 (defpsmacro 1- (form)
 319   `(- ,form 1))
 320
 321 (defpsmacro 1+ (form)
 322   `(+ ,form 1))