(/debug "loading compiler-codegen.lisp!")
+(defvar *js-macros* nil)
+(defmacro define-js-macro (name lambda-list &body body)
+ (let ((form (gensym)))
+ `(push (cons ',name
+ (lambda (,form)
+ (block ,name
+ (destructuring-bind ,lambda-list ,form
+ ,@body))))
+ *js-macros*)))
+
+(defun js-macroexpand (js)
+ (if (and (consp js) (assoc (car js) *js-macros*))
+ (let ((expander (cdr (assoc (car js) *js-macros*))))
+ (multiple-value-bind (expansion stop-expand-p)
+ (funcall expander (cdr js))
+ (if stop-expand-p
+ expansion
+ (js-macroexpand expansion))))
+ js))
+
+
(defconstant no-comma 12)
(defvar *js-output* t)
(case (length (cdr form))
(1 `(unary- ,(cadr form)))
(t (reduce (lambda (x y) `(- ,x ,y)) (cdr form)))))
+ ((and or)
+ (reduce (lambda (x y) `(,(car form) ,x ,y)) (cdr form)))
((progn comma)
(reduce (lambda (x y) `(comma ,x ,y)) (cdr form) :from-end t))
- (t form))
+ (t
+ (js-macroexpand form)))
form))
(defun js-operator-expression (op args precedence associativity operand-order)
(let ((op1 (car args))
(op2 (cadr args)))
(case op
- ;; Transactional compatible operator
- (code
- (js-format "~a" (apply #'code args)))
;; Accessors
(property
- (js-expr (car args))
+ (js-expr (car args) 0)
(js-format "[")
(js-expr (cadr args) no-comma)
(js-format "]"))
(get
- (multiple-value-bind (identifier identifierp)
- (valid-js-identifier (car args))
- (multiple-value-bind (accessor accessorp)
- (valid-js-identifier (cadr args))
- (cond
- ((and identifierp accessorp)
- (js-identifier identifier)
- (js-format ".")
- (js-identifier accessor))
- (t
- (js-expr (car args))
- (js-format "[")
- (js-expr (cadr args))
- (js-format "]"))))))
+ (multiple-value-bind (accessor accessorp)
+ (valid-js-identifier (cadr args))
+ (unless accessorp
+ (error "Invalid accessor ~S" (cadr args)))
+ (js-expr (car args) 0)
+ (js-format ".")
+ (js-identifier accessor)))
;; Function call
(call
(js-expr (car args) 1)
(t
`(group ,@(cdr form))))))
(t
- form)))
+ (js-macroexpand form))))
(defun js-stmt (form &optional parent)
(let ((form (js-expand-stmt form)))
(js-format ";")))
(t
(case (car form)
- (code
- (js-format "~a" (apply #'code (cdr form))))
(label
(destructuring-bind (label &body body) (cdr form)
(js-identifier label)
(js-format ":")
(js-stmt `(progn ,@body))))
(break
- (destructuring-bind (label) (cdr form)
- (js-format "break ")
- (js-identifier label)
+ (destructuring-bind (&optional label) (cdr form)
+ (js-format "break")
+ (when label
+ (js-format " ")
+ (js-identifier label))
(js-format ";")))
(return
(destructuring-bind (value) (cdr form)
(js-expr condition)
(js-format ")")
(js-stmt `(progn ,@body))))
+ (switch
+ (destructuring-bind (value &rest cases) (cdr form)
+ (js-format "switch(")
+ (js-expr value)
+ (js-format "){")
+ (dolist (case cases)
+ (cond
+ ((and (consp case) (eq (car case) 'case))
+ (js-format "case ")
+ (let ((value (cadr case)))
+ (unless (or (stringp value) (integerp value))
+ (error "Non-constant switch case `~S'." value))
+ (js-expr value))
+ (js-format ":"))
+ ((eq case 'default)
+ (js-format "default:"))
+ (t
+ (js-stmt case))))
+ (js-format "}")))
(for
(destructuring-bind ((start condition step) &body body) (cdr form)
(js-format "for (")