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