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-progns (body)
  78   (unless (null body)
  79     (if (and (listp (car body))
  80              (eql 'progn (caar body)))
  81         (append (cdar body) (flatten-progns (cdr body)))
  82         (cons (car body) (flatten-progns (cdr body))))))
  83
  84 (define-ps-special-form progn (expecting &rest body)
  85   (list 'js-block
  86         (if (eql expecting :statement) t nil)
  87         (remove nil (mapcar (lambda (form)
  88                               (compile-parenscript-form form :expecting :statement))
  89                             (flatten-progns 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                                    (mapcar (lambda (form) (compile-parenscript-form form :expecting :statement))
 127                                            body))))
 128                          clauses)))
 129
 130 (define-ps-special-form if (expecting test then &optional else)
 131   (ecase expecting
 132     (:statement (list 'js-statement-if (compile-parenscript-form test :expecting :expression)
 133                       (compile-parenscript-form `(progn ,then))
 134                       (when else (compile-parenscript-form `(progn ,else)))))
 135     (:expression (list 'js-expression-if (compile-parenscript-form test :expecting :expression)
 136                        (compile-parenscript-form then :expecting :expression)
 137                        (when else (compile-parenscript-form else :expecting :expression))))))
 138
 139 (define-ps-special-form switch (expecting test-expr &rest clauses)
 140   (let ((clauses (mapcar (lambda (clause)
 141                              (let ((val (car clause))
 142                                    (body (cdr clause)))
 143                                (list (if (eql val 'default)
 144                                          'default
 145                                          (compile-parenscript-form val :expecting :expression))
 146                                      (compile-parenscript-form `(progn ,@body)))))
 147                          clauses))
 148         (expr (compile-parenscript-form test-expr :expecting :expression)))
 149     (list 'js-switch expr clauses)))
 150
 151 ;;; assignment
 152 (defun assignment-op (op)
 153   (case op
 154     (+ '+=)
 155     (~ '~=)
 156     (\& '\&=)
 157     (\| '\|=)
 158     (- '-=)
 159     (* '*=)
 160     (% '%=)
 161     (>> '>>=)
 162     (^  '^=)
 163     (<< '<<=)
 164     (>>> '>>>=)
 165     (/   '/=)
 166     (t   nil)))
 167
 168 (defun smart-setf (lhs rhs)
 169   (if (and (listp rhs)
 170            (eql 'operator (car rhs))
 171            (member lhs (third rhs) :test #'equalp))
 172       (let ((args-without (remove lhs (third rhs) :count 1 :test #'equalp))
 173             (args-without-first (remove lhs (third rhs) :count 1 :end 1 :test #'equalp)))
 174         (cond ((and (equal (car args-without) 1) (eql (second rhs) '+))
 175                (list 'unary-operator "++" lhs :prefix nil))
 176               ((and (equal (second args-without-first) 1) (eql (second rhs) '-))
 177                (list 'unary-operator "--" lhs :prefix nil))
 178               ((and (assignment-op (second rhs))
 179                     (member (second rhs) '(+ *))
 180                     (equalp lhs (first (third rhs))))
 181                (list 'operator (assignment-op (second rhs))
 182                      (list lhs (list 'operator (second rhs) args-without-first))))
 183               ((and (assignment-op (second rhs)) (equalp (first (third rhs)) lhs))
 184                (list 'operator (assignment-op (second rhs))
 185                      (list lhs (list 'operator (second rhs) (cdr (third rhs))))))
 186               (t (list 'js-assign lhs rhs))))
 187       (list 'js-assign lhs rhs)))
 188
 189 (define-ps-special-form setf1% (expecting lhs rhs)
 190   (smart-setf (compile-parenscript-form lhs :expecting :expression) (compile-parenscript-form rhs :expecting :expression)))
 191
 192 (define-ps-special-form defvar (expecting name &rest value)
 193   (append (list 'js-defvar (compile-parenscript-form name :expecting :symbol))
 194           (when value
 195             (assert (= (length value) 1) () "Wrong number of arguments to defvar: ~s" `(defvar ,name ,@value))
 196            (list (compile-parenscript-form (car value) :expecting :expression)))))
 197
 198 ;;; iteration
 199 (defun make-for-vars (decls)
 200   (loop for decl in decls
 201         for var = (if (atom decl) decl (first decl))
 202         for init-value = (if (atom decl) nil (second decl))
 203         collect (cons (compile-parenscript-form var :expecting :symbol) (compile-parenscript-form init-value))))
 204
 205 (defun make-for-steps (decls)
 206   (loop for decl in decls
 207         when (= (length decl) 3)
 208         collect (compile-parenscript-form (third decl) :expecting :expression)))
 209
 210 (define-ps-special-form do (expecting decls termination-test &rest body)
 211   (let ((vars (make-for-vars decls))
 212         (steps (make-for-steps decls))
 213         (test (compile-parenscript-form `(not ,(first termination-test)) :expecting :expression))
 214         (body (compile-parenscript-form `(progn ,@body))))
 215     (list 'js-for vars steps test body)))
 216
 217 (define-ps-special-form doeach (expecting decl &rest body)
 218   (list 'js-for-each
 219         (compile-parenscript-form (first decl) :expecting :symbol)
 220         (compile-parenscript-form (second decl) :expecting :expression)
 221         (compile-parenscript-form `(progn ,@body))))
 222
 223 (define-ps-special-form while (expecting test &rest body)
 224   (list 'js-while (compile-parenscript-form test :expecting :expression)
 225                   (compile-parenscript-form `(progn ,@body))))
 226
 227 (define-ps-special-form with (expecting expression &rest body)
 228   (list 'js-with (compile-parenscript-form expression :expecting :expression)
 229                  (compile-parenscript-form `(progn ,@body))))
 230
 231 (define-ps-special-form try (expecting form &rest clauses)
 232   (let ((catch (cdr (assoc :catch clauses)))
 233         (finally (cdr (assoc :finally clauses))))
 234     (assert (not (cdar catch)) nil "Sorry, currently only simple catch forms are supported.")
 235     (list 'js-try (compile-parenscript-form `(progn ,form))
 236           :catch (when catch (list (compile-parenscript-form (caar catch) :expecting :symbol)
 237                                    (compile-parenscript-form `(progn ,@(cdr catch)))))
 238           :finally (when finally (compile-parenscript-form `(progn ,@finally))))))
 239
 240 (define-ps-special-form regex (expecting regex)
 241   (list 'js-regex (string regex)))
 242
 243 ;;; TODO instanceof
 244 (define-ps-special-form instanceof (expecting value type)
 245   (list 'js-instanceof (compile-parenscript-form value :expecting :expression)
 246         (compile-parenscript-form type :expecting :expression)))
 247
 248 ;;; single operations
 249 (mapcar (lambda (op) (eval `(define-ps-special-form ,op (expecting value)
 250                              (list 'js-named-operator ',op (compile-parenscript-form value)))))
 251         '(throw delete void typeof new))
 252
 253 (define-ps-special-form return (expecting &optional value)
 254   (list 'js-return (compile-parenscript-form value :expecting :expression)))
 255
 256 ;;; conditional compilation
 257 (define-ps-special-form cc-if (expecting test &rest body)
 258   (list 'cc-if test (mapcar #'compile-parenscript-form body)))
 259
 260 ;;; standard macros
 261 (defpsmacro when (test &rest body)
 262   `(if ,test (progn ,@body)))
 263
 264 (defpsmacro unless (test &rest body)
 265   `(if (not ,test) (progn ,@body)))
 266
 267 (defpsmacro 1- (form)
 268   `(- ,form 1))
 269
 270 (defpsmacro 1+ (form)
 271   `(+ ,form 1))
 272
 273 ;;; helper macros
 274 (define-ps-special-form js (expecting &rest body)
 275   (string-join (ps-print (compile-parenscript-form `(progn ,@body)) 0) " "))
 276
 277 (define-ps-special-form ps-inline (expecting &rest body)
 278   (concatenate 'string
 279                "javascript:"
 280                (string-join (reduce #'append (mapcar (lambda (form)
 281                                                        (ps-print (compile-parenscript-form form :expecting :statement)
 282                                                                  0))
 283                                                      body))
 284                             ";")
 285                ";"))
 286