;;; It is intended to be used with the new compiler. However, it is
;;; quite independent so it has been integrated early in JSCL.
+(/debug "loading compiler-codegen.lisp!")
+
(defvar *js-output* t)
;;; Two seperate functions are needed for escaping strings:
(defun valid-js-identifier (string-designator)
(let ((string (typecase string-designator
- (symbol (string-downcase (symbol-name string-designator)))
+ (symbol (symbol-name string-designator))
(string string-designator)
(t
(return-from valid-js-identifier (values nil nil))))))
(js-format "~a" (js-escape-string form)))
((symbolp form)
(case form
- (true (js-format "true"))
- (false (js-format "false"))
- (null (js-format "null"))
- (this (js-format "this"))
+ (true (js-format "true"))
+ (false (js-format "false"))
+ (null (js-format "null"))
+ (this (js-format "this"))
+ (undefined (js-format "undefined"))
(otherwise
(js-identifier form))))
(t
(js-format ",")
(js-identifier arg)))
(js-format ")")
- (js-stmt `(group ,@body)))
+ (js-stmt `(group ,@body) t))
(defun check-lvalue (x)
(unless (or (symbolp x)
(nth-value 1 (valid-js-identifier x))
(and (consp x)
- (member (car x) '(get =))))
+ (member (car x) '(get = property))))
(error "Bad Javascript lvalue ~S" x)))
;;; Process the Javascript AST to reduce some syntax sugar.
(let ((op1 (car args))
(op2 (cadr args)))
(case op
+ ;; Transactional compatible operator
+ (code
+ (js-format "~a" (apply #'code args)))
;; Function call
(call
(js-expr (car args))
(js-expr operand)))))
(js-format ")"))
;; Accessors
+ (property
+ (js-expr (car args))
+ (js-format "[")
+ (js-expr (cadr args))
+ (js-format "]"))
(get
(multiple-value-bind (identifier identifierp)
(valid-js-identifier (car args))
(t
(js-operator-expression (car form) (cdr form))))))
-(defun js-stmt (form)
- (if (atom form)
- (progn
- (js-expr form)
- (js-format ";"))
- (case (car 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)
+(defun js-expand-stmt (form)
+ (cond
+ ((and (consp form) (eq (car form) 'progn))
+ (destructuring-bind (&body body) (cdr form)
+ (cond
+ ((null body)
+ nil)
+ ((null (cdr body))
+ (js-expand-stmt (car body)))
+ (t
+ `(group ,@(cdr form))))))
+ (t
+ form)))
+
+(defun js-stmt (form &optional parent)
+ (let ((form (js-expand-stmt form)))
+ (flet ((js-stmt (x) (js-stmt x form)))
+ (cond
+ ((null form)
+ (unless (or (and (consp parent) (eq (car parent) 'group))
+ (null parent))
+ (js-format ";")))
+ ((atom form)
+ (progn
+ (js-expr form)
(js-format ";")))
- (return
- (destructuring-bind (value) (cdr form)
- (js-format "return ")
- (js-expr value)
- (js-format ";")))
- (var
- (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)
- (js-format "if (")
- (js-expr condition)
- (js-format ") ")
- (js-stmt true)
- (when false
- (js-format " else ")
- (js-stmt false))))
- (group
- (js-format "{")
- (mapc #'js-stmt (cdr form))
- (js-format "}"))
- (progn
- (cond
- ((null (cdr form))
- (js-format ";"))
- ((null (cddr form))
- (js-stmt (cadr form)))
- (t
- (js-stmt `(group ,@(cdr form))))))
- (while
- (destructuring-bind (condition &body body) (cdr form)
- (js-format "while (")
+ (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)
+ (js-format ";")))
+ (return
+ (destructuring-bind (value) (cdr form)
+ (js-format "return ")
+ (js-expr value)
+ (js-format ";")))
+ (var
+ (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)
+ (js-format "if (")
(js-expr condition)
- (js-format ")")
+ (js-format ") ")
+ (js-stmt true)
+ (when false
+ (js-format " else ")
+ (js-stmt false))))
+ (group
+ (let ((in-group-p
+ (or (null parent)
+ (and (consp parent) (eq (car parent) 'group)))))
+ (unless in-group-p (js-format "{"))
+ (mapc #'js-stmt (cdr form))
+ (unless in-group-p (js-format "}"))))
+ (while
+ (destructuring-bind (condition &body body) (cdr form)
+ (js-format "while (")
+ (js-expr condition)
+ (js-format ")")
+ (js-stmt `(progn ,@body))))
+ (try
+ (destructuring-bind (&rest body) (cdr form)
+ (js-format "try")
(js-stmt `(group ,@body))))
- (t
- (js-expr form)
- (js-format ";")))))
+ (catch
+ (destructuring-bind ((var) &rest body) (cdr form)
+ (js-format "catch (")
+ (js-identifier var)
+ (js-format ")")
+ (js-stmt `(group ,@body))))
+ (finally
+ (destructuring-bind (&rest body) (cdr form)
+ (js-format "finally")
+ (js-stmt `(group ,@body))))
+ (throw
+ (destructuring-bind (object) (cdr form)
+ (js-format "throw ")
+ (js-expr object)
+ (js-format ";")))
+ (t
+ (js-expr form)
+ (js-format ";"))))))))
(defun js (&rest stmts)
(mapc #'js-stmt stmts)
projects / jscl.git / blobdiff