(defun js-primary-expr (form)
(cond
((numberp form)
- (js-format "~a" form))
+ (if (<= 0 form)
+ (js-format "~a" form)
+ (js-expr `(- ,(abs form)))))
((stringp form)
(js-format "~a" (js-escape-string form)))
((symbolp form)
(case (length (cdr form))
(1 `(unary- ,(cadr form)))
(t (reduce (lambda (x y) `(- ,x ,y)) (cdr form)))))
+ ((progn comma)
+ (reduce (lambda (x y) `(comma ,x ,y)) (cdr form) :from-end t))
(t form))
form))
;; Initialized to any value larger than any operator precedence
(defvar *js-operator-precedence* 1000)
(defvar *js-operator-associativity* 'left)
+(defvar *js-operand-order* 'left)
+
+;; Format an expression optionally wrapped with parenthesis if the
+;; precedence rules require it.
+(defmacro with-operator ((precedence associativity) &body body)
+ (let ((g!parens (gensym))
+ (g!precedence (gensym)))
+ `(let* ((,g!precedence ,precedence)
+ (,g!parens
+ (cond
+ ((> ,g!precedence *js-operator-precedence*))
+ ((< ,g!precedence *js-operator-precedence*) nil)
+ ;; Same precedence. Let us consider associativity.
+ (t
+ (not (eq *js-operand-order* *js-operator-associativity*)))))
+ (*js-operator-precedence* ,g!precedence)
+ (*js-operator-associativity* ,associativity)
+ (*js-operand-order* 'left))
+ (when ,g!parens (js-format "("))
+ (progn ,@body)
+ (when ,g!parens (js-format ")")))))
+
+(defun js-operator (string)
+ (js-format "~a" string)
+ (setq *js-operand-order* 'right))
(defun js-operator-expression (op args)
- (macrolet (;; Format an expression optionally wrapped with
- ;; parenthesis if the precedence rules require it.
- (with-operator ((level associativity) &body body)
- (let ((g!parens (gensym))
- (g!level (gensym)))
- `(let* ((,g!level ,level)
- (,g!parens
- (cond
- ((> ,g!level *js-operator-precedence*))
- ((< ,g!level *js-operator-precedence*) nil)
- (t
- t)))
- (*js-operator-precedence* ,g!level)
- (*js-operator-associativity* ,associativity))
- (when ,g!parens (js-format "("))
- (progn ,@body)
- (when ,g!parens (js-format ")"))))))
- (let ((op1 (car args))
- (op2 (cadr args)))
- (case op
- ;; Comma (,)
- ((progn comma)
- (with-operator (14 'left)
- (js-expr (car args))
- (dolist (operand (cdr args))
+ (let ((op1 (car args))
+ (op2 (cadr args)))
+ (case op
+ ;; Function call
+ (call
+ (js-expr (car args))
+ (js-format "(")
+ (when (cdr args)
+ (with-operator (13 'left)
+ (js-expr (cadr args))
+ (dolist (operand (cddr args))
(let ((*js-output* t))
(js-format ",")
(js-expr operand)))))
- ;; Function call
- (call
- (js-expr (car args))
- (js-format "(")
- (when (cdr args)
- (with-operator (13 'left)
- (js-expr (cadr args))
- (dolist (operand (cddr args))
- (let ((*js-output* t))
- (js-format ",")
- (js-expr operand)))))
- (js-format ")"))
- ;; Accessors
- (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 "]"))))))
- ;; Object syntax
- (object
- (js-object-initializer args))
- ;; Function expressions
- (function
- (js-format "(")
- (apply #'js-function args)
- (js-format ")"))
- (t
- (flet ((%unary-op (operator string precedence associativity post lvalue)
- (when (eq op operator)
- (with-operator (precedence associativity)
- (when lvalue (check-lvalue op1))
- (cond
- (post
- (js-expr op1)
- (js-format string))
- (t
- (js-format string)
- (js-expr op1))))
- (return-from js-operator-expression)))
- (%binary-op (operator string precedence associativity lvalue)
- (when (eq op operator)
+ (js-format ")"))
+ ;; Accessors
+ (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 "]"))))))
+ ;; Object syntax
+ (object
+ (js-object-initializer args))
+ ;; Function expressions
+ (function
+ (js-format "(")
+ (apply #'js-function args)
+ (js-format ")"))
+ (t
+ (flet ((%unary-op (operator string precedence associativity post lvalue)
+ (when (eq op operator)
+ (with-operator (precedence associativity)
(when lvalue (check-lvalue op1))
- (with-operator (precedence associativity)
- (js-expr op1)
- (js-format string)
- (js-expr op2))
- (return-from js-operator-expression))))
+ (cond
+ (post
+ (js-expr op1)
+ (js-operator string))
+ (t
+ (js-operator string)
+ (js-expr op1))))
+ (return-from js-operator-expression)))
+ (%binary-op (operator string precedence associativity lvalue)
+ (when (eq op operator)
+ (when lvalue (check-lvalue op1))
+ (with-operator (precedence associativity)
+ (js-expr op1)
+ (js-operator string)
+ (js-expr op2))
+ (return-from js-operator-expression))))
+
+ (macrolet ((unary-op (operator string precedence associativity &key post lvalue)
+ `(%unary-op ',operator ',string ',precedence ',associativity ',post ',lvalue))
+ (binary-op (operator string precedence associativity &key lvalue)
+ `(%binary-op ',operator ',string ',precedence ',associativity ',lvalue)))
- (macrolet ((unary-op (operator string precedence associativity &key post lvalue)
- `(%unary-op ',operator ',string ',precedence ',associativity ',post ',lvalue))
- (binary-op (operator string precedence associativity &key lvalue)
- `(%binary-op ',operator ',string ',precedence ',associativity ',lvalue)))
+ (unary-op pre++ "++" 1 right :lvalue t)
+ (unary-op pre-- "--" 1 right :lvalue t)
+ (unary-op post++ "++" 1 right :lvalue t :post t)
+ (unary-op post-- "--" 1 right :lvalue t :post t)
+ (unary-op not "!" 1 right)
+ (unary-op bit-not "~" 1 right)
+ ;; Note that the leading space is necessary because it
+ ;; could break with post++, for example. TODO: Avoid
+ ;; leading space when it's possible.
+ (unary-op unary+ " +" 1 right)
+ (unary-op unary- " -" 1 right)
+ (unary-op delete "delete " 1 right)
+ (unary-op void "void " 1 right)
+ (unary-op typeof "typeof " 1 right)
+ (unary-op new "new " 1 right)
- (unary-op pre++ "++" 1 right :lvalue t)
- (unary-op pre-- "--" 1 right :lvalue t)
- (unary-op post++ "++" 1 right :lvalue t :post t)
- (unary-op post-- "--" 1 right :lvalue t :post t)
- (unary-op not-- "!" 1 right)
- (unary-op unary+ "+" 1 right)
- (unary-op unary- "-" 1 right)
- (unary-op delete "delete " 1 right)
- (unary-op void "void " 1 right)
- (unary-op typeof "typeof " 1 right)
- (unary-op new "new " 1 right)
+ (binary-op * "*" 2 left)
+ (binary-op / "/" 2 left)
+ (binary-op mod "%" 2 left)
+ (binary-op % "%" 2 left)
+ (binary-op + "+" 3 left)
+ (binary-op - "-" 3 left)
+ (binary-op << "<<" 4 left)
+ (binary-op >> "<<" 4 left)
+ (binary-op >>> ">>>" 4 left)
+ (binary-op <= "<=" 5 left)
+ (binary-op < "<" 5 left)
+ (binary-op > ">" 5 left)
+ (binary-op >= ">=" 5 left)
+ (binary-op instanceof " instanceof " 5 left)
+ (binary-op in " in " 5 left)
+ (binary-op == "==" 6 left)
+ (binary-op != "!=" 6 left)
+ (binary-op === "===" 6 left)
+ (binary-op !== "!==" 6 left)
+ (binary-op bit-and "&" 7 left)
+ (binary-op bit-xor "^" 8 left)
+ (binary-op bit-or "|" 9 left)
+ (binary-op and "&&" 10 left)
+ (binary-op or "||" 11 left)
+ (binary-op = "=" 13 right :lvalue t)
+ (binary-op += "+=" 13 right :lvalue t)
+ (binary-op incf "+=" 13 right :lvalue t)
+ (binary-op -= "-=" 13 right :lvalue t)
+ (binary-op decf "-=" 13 right :lvalue t)
+ (binary-op *= "*=" 13 right :lvalue t)
+ (binary-op /= "*=" 13 right :lvalue t)
+ (binary-op bit-xor= "^=" 13 right :lvalue t)
+ (binary-op bit-and= "&=" 13 right :lvalue t)
+ (binary-op bit-or= "|=" 13 right :lvalue t)
+ (binary-op <<= "<<=" 13 right :lvalue t)
+ (binary-op >>= ">>=" 13 right :lvalue t)
+ (binary-op >>>= ">>>=" 13 right :lvalue t)
- (binary-op * "*" 2 left)
- (binary-op / "/" 2 left)
- (binary-op mod "%" 2 left)
- (binary-op % "%" 2 left)
- (binary-op + "+" 3 left)
- (binary-op - "-" 3 left)
- (binary-op << "<<" 4 left)
- (binary-op >> "<<" 4 left)
- (binary-op >>> ">>>" 4 left)
- (binary-op <= "<=" 5 left)
- (binary-op < "<" 5 left)
- (binary-op > ">" 5 left)
- (binary-op >= ">=" 5 left)
- (binary-op instanceof " instanceof " 5 left)
- (binary-op in " in " 5 left)
- (binary-op == "==" 6 left)
- (binary-op != "!=" 6 left)
- (binary-op === "===" 6 left)
- (binary-op !== "!==" 6 left)
- (binary-op bit-and "&" 7 left)
- (binary-op bit-xor "^" 8 left)
- (binary-op bit-or "|" 9 left)
- (binary-op and "&&" 10 left)
- (binary-op or "||" 11 left)
- (binary-op = "=" 13 right :lvalue t)
- (binary-op += "+=" 13 right :lvalue t)
- (binary-op incf "+=" 13 right :lvalue t)
- (binary-op -= "-=" 13 right :lvalue t)
- (binary-op decf "-=" 13 right :lvalue t)
- (binary-op *= "*=" 13 right :lvalue t)
- (binary-op /= "*=" 13 right :lvalue t)
- (binary-op bit-xor= "^=" 13 right :lvalue t)
- (binary-op bit-and= "&=" 13 right :lvalue t)
- (binary-op bit-or= "|=" 13 right :lvalue t)
- (binary-op <<= "<<=" 13 right :lvalue t)
- (binary-op >>= ">>=" 13 right :lvalue t)
- (binary-op >>>= ">>>=" 13 right :lvalue t)
+ (binary-op comma "," 13 right)
+ (binary-op progn "," 13 right)
- (WHEN (member op '(? if))
- (with-operator (12 'right)
- (js-expr (first args))
- (js-format "?")
- (js-expr (second args))
- (js-format ":")
- (js-expr (third args)))))))))))
+ (when (member op '(? if))
+ (with-operator (12 'right)
+ (js-expr (first args))
+ (js-operator "?")
+ (js-expr (second args))
+ (js-format ":")
+ (js-expr (third args)))
+ (return-from js-operator-expression))
+ (error "Unknown operator `~S'" op)))))))
(defun js-expr (form)
(let ((form (js-expand-expr form)))
(t
(js-operator-expression (car form) (cdr form))))))
-
(defun js-stmt (form)
(if (atom form)
(progn
(js-format ";"))
(case (car form)
(label
- (js-identifier (cadr form))
- (js-format ":")
- (js-stmt `(progn ,@(cddr form))))
+ (destructuring-bind (label &body body) (cdr form)
+ (js-identifier label)
+ (js-format ":")
+ (js-stmt `(progn ,@body))))
(break
- (js-format "break ")
- (js-identifier (second form))
- (js-format ";"))
+ (destructuring-bind (label) (cdr form)
+ (js-format "break ")
+ (js-identifier label)
+ (js-format ";")))
(return
- (js-format "return ")
- (js-expr (cadr form))
- (js-format ";"))
+ (destructuring-bind (value) (cdr form)
+ (js-format "return ")
+ (js-expr value)
+ (js-format ";")))
(var
- (destructuring-bind (var &rest vars) (cdr form)
- (js-format "var ")
- (js-identifier var)
- (dolist (var vars)
- (js-format ",")
- (js-identifier var))
- (js-format ";")))
+ (flet ((js-var (spec)
+ (destructuring-bind (variable &optional initial)
+ (ensure-list spec)
+ (js-identifier variable)
+ (when initial
+ (js-format "=")
+ (js-expr initial)))))
+ (destructuring-bind (var &rest vars) (cdr form)
+ (let ((*js-operator-precedence* 12))
+ (js-format "var ")
+ (js-var var)
+ (dolist (var vars)
+ (js-format ",")
+ (js-var var))
+ (js-format ";")))))
(if
- (destructuring-bind (condition true &optional false)
- (cdr form)
+ (destructuring-bind (condition true &optional false) (cdr form)
(js-format "if (")
(js-expr condition)
(js-format ") ")
(js-format ";")))))
(defun js (&rest stmts)
- (mapc #'js-stmt stmts))
+ (mapc #'js-stmt stmts)
+ nil)
projects / jscl.git / blobdiff