From 140d94ff2486c5c017ea4b7ce7b6a77a8675c4b8 Mon Sep 17 00:00:00 2001 From: =?utf8?q?David=20V=C3=A1zquez?= Date: Wed, 19 Jun 2013 06:13:49 +0200 Subject: [PATCH] More error checking --- experimental/codegen.lisp | 302 +++++++++++++++++++++++---------------------- 1 file changed, 153 insertions(+), 149 deletions(-) diff --git a/experimental/codegen.lisp b/experimental/codegen.lisp index 8fd365a..b03fdc9 100644 --- a/experimental/codegen.lisp +++ b/experimental/codegen.lisp @@ -176,155 +176,156 @@ (defvar *js-operator-precedence* 1000) (defvar *js-operator-associativity* '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) + (t + t))) + (*js-operator-precedence* ,g!precedence) + (*js-operator-associativity* ,associativity)) + (when ,g!parens (js-format "(")) + (progn ,@body) + (when ,g!parens (js-format ")"))))) + (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 + ;; Comma (,) + ((progn comma) + (with-operator (14 'left) + (js-expr (car args)) + (dolist (operand (cdr 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))))) - ;; 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-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) + (when lvalue (check-lvalue op1)) + (with-operator (precedence associativity) + (js-expr op1) + (js-format 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 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) - (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-format "?") + (js-expr (second args)) + (js-format ":") + (js-expr (third args)))))))))) (defun js-expr (form) @@ -345,17 +346,20 @@ (js-format ";")) (case (car form) (label - (js-identifier (cadr form)) - (js-format ":") - (js-stmt `(progn ,@(cddr form)))) + (destructuring-bind (label &body body) form + (js-identifier label) + (js-format ":") + (js-stmt `(progn ,@body)))) (break - (js-format "break ") - (js-identifier (second form)) - (js-format ";")) + (destructuring-bind (label) form + (js-format "break ") + (js-identifier label) + (js-format ";"))) (return - (js-format "return ") - (js-expr (cadr form)) - (js-format ";")) + (destructuring-bind (value) form + (js-format "return ") + (js-expr value) + (js-format ";"))) (var (destructuring-bind (var &rest vars) (cdr form) (js-format "var ") -- 1.7.10.4